perm filename GEN[S,AIL]40 blob
sn#135717 filedate 1974-12-13 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00064 PAGES VERSION 17-1(225)
RECORD PAGE DESCRIPTION
00001 00001
00013 00002 HISTORY
00035 00003 LSTON (GEN)
00043 00004 TABLEDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
00048 00005 TABCONDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
00051 00006 DSCR GENINI
00055 00007 DSCR GETOP, GETADL, GETAD
00057 00008 DSCR -- SAIL DECLARATION EXECS
00062 00009 DSCR TYPSET, VALSET, XOWSET, etc.
00065 00010 DSCR TCON, BTRU, BFAL, BNUL, BINF
00068 00011 DSCR TWID10, ECHK, ESET
00071 00012 DSCR DWN, BLOCK, BLNAME, ENTID, UP, NAMCHK, etc.
00083 00013 ↑ENTID:
00089 00014
00096 00015 Check for match on block names.
00097 00016 DSCR RQ00, RQSET, SRCSWT
00103 00017
00105 00018
00110 00019
00113 00020 ↑SRCSWT:
00114 00021 DSCR DFPREP, DCPREP, DWPREP, DFPINS, DFSET, DFENT, MACOFF, MACON
00127 00022 DSCR STCAT
00139 00023 DSCR DCLNT1,DCLNT2
00145 00024 DSCR CNDRCY, CNDRCN, CNDRCP
00152 00025 DSCR LETSET, LETENT
00155 00026 DSCR TWCOND,SWICHP,SWPOFF,PSWICH,OKEOF
00163 00027 ↑SETWHL: EXCH SP,STPSAV GET STRING POINTER
00177 00028 SUBTTL EXECS for Entry Declaration
00179 00029 DSCR ALOT
00184 00030 ↑ALOT: ROUTINE TO HANDLE ALLOCATION
00188 00031
00192 00032 BAIL <
00203 00033
00209 00034 Comment
00215 00035 NOSY: PUSHJ P,URGSTR IF ON STRING RING....
00225 00036 LOADER BLOCK FOR POLISH FIXUP
00227 00037 DSCR PDOUT
00233 00038 DOLVIN: PUSH P,PNT2
00237 00039 ROUTINE TO PUT OUT LOCAL VAR INFO -- USED BY DIS
00243 00040 %AA% -- SDFLTS
00244 00041 Allo -- Allocate One Type of Symbol
00250 00042 ROUTINE TO ALLOCATE SPACE FOR TEMP CELLS AND TO OUTPUT
00256 00043 REQINI -- USER REQUIRED INITIALIZTIONS
00261 00044 DSCR DONES
00265 00045
00273 00046 REN <
00275 00047
00279 00048
00286 00049 MEMORY and LOCATION EXECS, ALSO UINCLL
00289 00050 MINOR RECORD EXECS
00296 00051 RCFPIK -- ROUTINE TO DECODE RECORD INDEX
00298 00052 RCFREF -- EXEC ROUTINE FOR HANDLING RECORD FIELD REFERENCES
00304 00053 RECORD TYPE JUSTIFICATION ROUTINE
00306 00054 ROUTINE TO HANLDE REFERENCE COUNT ADJUSTMENT
00310 00055 DSCR MAKBUK, FREBUK
00312 00056 BEGIN ERRORS
00318 00057 DSCR SCNBAK,POPBAK,KILPOP,QREM2,QTYPCK
00323 00058 DSCR UNDEC -- Undeclared identifiers
00329 00059 DSCR QDEC0,1,2 QARSUB QARDEC QPARM QPRDEC
00336 00060 BEGIN SCOMM
00337 00061 BEGIN INLINE
00339 00062 DSCR CODNIT, WRDNIT, ONEWRD, SETSIX, SETOP, CODIND, CODREG, etc.
00347 00063 ↑CESSGO:MOVE TEMP,OPDUN SAVING OPDUN
00353 00064 BEGIN COUNT
00356 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021 102100000341 ⊗;
COMMENT ⊗
VERSION 17-1(225) 12-13-74 BY JFR BAIL EXTERNAL LINKAGE
VERSION 17-1(224) 12-10-74 BY JFR BAIL--FORCE COORDINATES OUT AT BEGINs
VERSION 17-1(223) 12-10-74 BY JFR FIX INFO ON PROCEDURES FOR .SM1 FILE
VERSION 17-1(222) 12-10-74 BY JFR TRY TO FIX BAIL INTERNAL/EXTERNAL LINKAGE
VERSION 17-1(221) 12-7-74 BY JFR ATTEMPT TO FIX BAIL INTERNAL/EXTRNAL LINKAGE. POSTPONED
VERSION 17-1(220) 12-7-74 BY JFR MAKE REQUIRE "SYS:BAIL.REL" LOAD!MODULE AUTOMATIC UNDER BAIL SWITCH
VERSION 17-1(219) 11-13-74 BY JFR BAIL BUG P. 32
VERSION 17-1(218) 11-13-74 BY JFR BAIL FIX P.45
VERSION 17-1(217) 11-8-74 BY JFR FIX BAIL DEFAULT BLOCK NAME CREATION AND COUNTING
VERSION 17-1(216) 11-7-74 BY JFR BAIL--CREATED BLOCK NAMES PUT OUT AT BAISYM RATHER THAN AT BEGIN
VERSION 17-1(215) 11-3-74 BY RHT BUG #TR# REQUIRE SPACE CODE
VERSION 17-1(214) 10-13-74 BY JFR JUST CHECKING
VERSION 17-1(213) 10-13-74 BY JFR BAIL--DON'T INVENT BLOCK NAMES IF NOT A BAIL COMPILATION
VERSION 17-1(212) 10-10-74 BY RHT FEAT %BR% REMOVE HACKS
VERSION 17-1(211) 9-29-74 BY JFR BAIL BUG P.12
VERSION 17-1(210) 9-26-74 BY JFR INSERT MISSING ZERODATA AROUND %%VARB (P.59)
VERSION 17-1(209) 9-26-74 BY JFR BAIL--CHANGES TO WHICH SYMBOLS GO TO .SM1 FILE
VERSION 17-1(208) 9-24-74 BY JFR FIX BAIL .SM1 DEC-10 IO
VERSION 17-1(207) 9-20-74 BY JFR QUALITY CONTROL
VERSION 17-1(206) 9-20-74 BY JFR INSTALL BAIL
VERSION 17-1(205) 9-20-74
VERSION 17-1(204) 9-20-74
VERSION 17-1(203) 9-19-74
VERSION 17-1(202) 9-19-74
VERSION 17-1(201) 8-8-74 BY JRL BUG #TA# ASSIGNC SCREWED UP WHEN GIVEN CONSTANT EXPRESSION
VERSION 17-1(200) 8-5-74 BY JRL BUG #SZ# (CMU =C7=) LPSA WASN'T BEING SAVED IN CLENUP
VERSION 17-1(201) 9-19-74
VERSION 17-1(199) 7-7-74 BY RHT MANY EDITS FOR RECGC
VERSION 17-1(198) 7-7-74
VERSION 17-1(197) 7-7-74
VERSION 17-1(196) 7-7-74
VERSION 17-1(195) 7-7-74
VERSION 17-1(194) 7-7-74
VERSION 17-1(193) 7-7-74
VERSION 17-1(192) 7-7-74
VERSION 17-1(191) 7-7-74
VERSION 17-1(190) 7-5-74 BY RHT BUG #SS# RECORD INDXED TEMPS AC NOT IN ACKTAB
VERSION 17-1(189) 6-2-74 BY RHT MODIFY RCBIT0
VERSION 17-1(188) 5-30-74 BY RLS BUG #SN# ALLOW RECURSIVE EXPR!TYPE CALLS
VERSION 17-1(187) 5-29-74 BY RHT BUG #SG# EMITER WAS MODIFYING ADCONS
VERSION 17-1(186) 5-27-74 BY RHT MARK RECORD ARRAYS AS SUCH IN THE PD LVI
VERSION 17-1(185) 5-27-74
VERSION 17-1(184) 5-27-74 BY RHT ADD DEREFERENCE AT PRST FOR RECORD PROCEDURES
VERSION 17-1(183) 5-5-74 BY RHT BUG RW FIX TO BUG FIX #RNR
VERSION 17-1(182) 4-12-74
VERSION 17-1(181) 4-12-74
VERSION 17-1(180) 4-12-74
VERSION 17-1(179) 4-12-74
VERSION 17-1(178) 4-12-74
VERSION 17-1(177) 4-12-74
VERSION 17-1(176) 4-12-74
VERSION 17-1(175) 4-12-74
VERSION 17-1(174) 4-8-74 BY RHT %BI% -- ADDED MINOR CHANGES IN LVIOUT
VERSION 17-1(173) 3-26-74 BY JFR ADD WRITEON RUNTIME TO LIBFN LIST
VERSION 17-1(172) 3-19-74 BY RHT LOOK OVER WITH RLS
VERSION 17-1(171) 3-17-74 BY RLS INSTALL TENEX
VERSION 17-1(170) 3-16-74 BY RHT BUG #RN# PROTECT_ACS LOSSAGE
VERSION 17-1(169) 2-22-74 BY RHT BUG #RJ# ALWAYS PUT OUT LVI FOR SETS
VERSION 17-1(168) 2-5-74 BY HJS BUG #RA# ALLOW TEXT PAST END OF PROGRAM
VERSION 17-1(167) 1-29-74 BY HJS BUG #QV# ADD ASGOFF TO TURN OFF SPECIAL ASSIGNC SCANNING
VERSION 17-1(166) 1-28-74 BY RHT SHORTEN LONG ERROR MESSAGE (ER24)
VERSION 17-1(165) 1-27-74 BY JRL BUG #QT# GIVE BETTER RECOVERY FOR EXTRA ELSE'S
VERSION 17-1(164) 1-25-74 BY RHT FIX TYPO IN BUG QK
VERSION 17-1(163) 1-16-74 BY RHT BUG #QK# REQUIRE RUNTIMEROUTINE INITIALIZATION
VERSION 17-1(162) 1-16-74 BY RHT BUG #QJ# PD WRONG FOR SG ITEMVAR ARRAY
VERSION 17-1(161) 1-16-74
VERSION 17-1(160) 1-11-74 BY JRL CMU CHANGE SPACE ALLOCATION BLOCK SIZE
VERSION 17-1(159) 1-11-74
VERSION 17-1(158) 1-11-74
VERSION 17-1(157) 1-11-74
VERSION 17-1(156) 1-6-74 BY KVL ADD %BC% ALL THE STUFF ON PGS 32 AND 33 -- BAIL SYM OUTPUTING
VERSION 17-1(155) 12-7-73 BY JRL REMOVE STANFORD SPECIAL CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(154) 12-2-73 BY RHT BUG #PK# MAKE START CODE DO REMOPS
VERSION 17-1(153) 11-29-73 BY RHT EXPAND EXPLANATION OF AN ERROR MESSAGE
VERSION 17-1(152) 11-25-73
VERSION 17-1(151) 11-25-73 BY JRL FEAT %AN% ALLOW REQUIRE TO USE CONSTANT EXPRESSIONS
VERSION 17-1(150) 11-25-73 BY RHT FEAT %AL% OUTER BLOCK LOOKS LIKE A PROCEDURE
VERSION 17-1(149) 11-25-73 BY KVL IMPROVE CODING STYLE IN REQUIRE ERROR!MODES LINK TO DSPATC
VERSION 17-1(148) 11-24-73 BY RHT FEAT %AM% ALLOW USER TO SPECIFY INIT PHASE
VERSION 17-1(147) 11-24-73 BY RHT GET VERSION BACK
VERSION 17-1(146) 11-24-73
VERSION 17-1(145) 11-10-73 BY KVL INSERT LOG ERR UUO STUFF
VERSION 17-1(144) 11-10-73
VERSION 17-1(143) 10-31-73 BY HJS BUG #OS# DETECT UNDECLARED ARGUMENT TO CVMS
VERSION 17-1(142) 10-30-73 BY RHT BUG #OB# SDFLTS NEEDED TO DO CLRSET
VERSION 17-1(141) 10-23-73 BY JRL FEATURE %AG% ITEM!START STUFF
VERSION 17-1(140) 9-27-73 BY KVL %AC% REMOVE GLOBAL DECL OPTION IN ERROR RECOVERY
VERSION 17-1(139) 9-27-73
VERSION 17-1(138) 9-21-73 BY HJS INHIBIT LST FALSE PART OF CONDITIONAL COMPILATION
VERSION 17-1(137) 9-19-73 BY HJS ADD CVPS AND EVALREDEFINE
VERSION 17-1(136) 9-1-73 BY RHT FEATURE %AA% -- SPROUT DEFAULTS
VERSION 17-1(135) 8-16-73 BY jrl REMOVE REFERENCES TO LEP SWITCH
VERSION 17-1(134) 8-12-73 BY JRL BUG #NQ# STRING ITEMVAR IS NOT A STRING
VERSION 17-1(133) 8-12-73
VERSION 17-1(132) 7-26-73 BY RHT **** VERSION 17 ****
VERSION 16-2(131) 7-22-73 BY JRL BUG #KU# BAD FIX, ARRAY ITEMS SHOULD NOT BE OWN
VERSION 16-2(130) 7-14-73 BY RHT ADD AN APPL$Y,SETIP,SETCP TO LIBTAB
VERSION 16-2(129) 7-12-73 BY JRL ADD REQUIRE BUCKETS
VERSION 16-2(128) 7-12-73
VERSION 16-2(127) 7-12-73
VERSION 16-2(126) 7-12-73
VERSION 16-2(125) 7-12-73
VERSION 16-2(124) 6-20-73 BY JRL BUG #MS# LET NOT WORKING WHEN RIGHT SIDE A TRIGGERER
VERSION 16-2(123) 6-20-73
VERSION 16-2(122) 6-20-73 BY HJS IFCR, REDEFINE, EVALDEFINE, AND ASSIGNC IMPLEMENTATION
VERSION 16-2(121) 5-9-73 BY HJS REMOP STRING CONSTANTS
VERSION 16-2(120) 5-7-73 BY JRL ADD ERRMSG FOR BAD CONTEXT ELEMENT SYNTAX
VERSION 16-2(119) 5-4-73
VERSION 16-2(118) 5-4-73
VERSION 16-2(117) 5-4-73
VERSION 16-2(116) 4-23-73
VERSION 16-2(115) 4-23-73 BY RHT CHANGE PROC DESC FOR PROC ARGS
VERSION 16-2(114) 4-23-73
VERSION 16-2(113) 4-22-73 BY RHT FIX UNDISCOVERED LVI BUG
VERSION 16-2(112) 4-21-73 BY RHT BUG #MC#
VERSION 16-2(111) 3-22-73 BY RHT ADD DEFAULT VALUES FOR PARAMS
VERSION 16-2(110) 3-20-73 BY RHT CHANGE FORMAL SEMBLK DELETION
VERSION 16-2(109) 3-19-73 BY HJS ALLOW TEMPORARY OVERRIDING OF NULL DELIMITERS MODE
VERSION 16-2(108) 3-13-73 BY JRL REMOVE SLS,WOM,NODIS,GAG CONDITIONAL
VERSION 16-2(107) 3-7-73 BY KVL ADD ACCESS CONSTRUCT FEATURE
VERSION 16-2(107) 3-6-73 BY JRL ADD ALLGLOBAL REQUIRE
VERSION 16-2(106) 3-5-73 BY JRL ADD OKSTAC TO DCLBEG
VERSION 16-2(105) 2-27-73 BY JRL REMOVE ..RVAL FROM LIBTAB
VERSION 16-2(104) 2-21-73 BY RHT ADD EXEC TYPMSG (P19) FOR REQUIRE STC MESSAGE
VERSION 16-2(103) 2-12-73 BY JRL ADD ..RVAL TO LIBTAB
VERSION 16-2(102) 1-28-73 BY JRL REMOVE BOUND FROM SYNTAX
VERSION 16-2(101) 1-26-73 BY JRL ADD INCONT TO LIBTAB
VERSION 16-2(100) 1-26-73 BY JRL ADD ERRMSG FOR SAMEIV AND IN!CONTEXT
VERSION 16-2(99) 1-25-73 BY JRL HALF-KILL ITEMS WITH NOS. < 20
VERSION 16-2(98) 1-25-73 BY JRL MOD ERRMSG ERR112 TO INCLUDE ?
VERSION 16-2(97) 1-24-73 BY KVL INSTALL ENTENT EXEC, MAKING DUMMY SYMBOLS TO ENTRY UNNECESSARY
VERSION 16-2(96) 1-9-73 BY RHT BUG #KT# TYPO IN UP
VERSION 16-2(95) 1-9-73 BY RHT BUG #KY# ALLOW GLOBAL INTERNAL SYMBOLS TO GO OUT ALWAYS
VERSION 16-2(94) 1-9-73 BY RHT BUG #KX# NEED ALLSTO BEFORE BEXIT
VERSION 16-2(93) 1-8-73 BY JRL BUG KW DON'T ALLOW INTERNAL OR EXTERNAL ITEM DECLARATIONS
VERSION 16-2(92) 1-8-73
VERSION 16-2(91) 1-8-73
VERSION 16-2(90) 12-13-72 BY HJS FIX RACE CONDITION WHERE MACROS AND CONDITIONAL COMPILATION END SIMULTANEOUSLY
VERSION 16-2(89) 12-11-72 BY HJS ENDC PARSER SWITCH TRIGGER IN WHILEC, CASEC, FORC, AND FORLC BODIES
VERSION 16-2(88) 12-2-72 BY HJS SAVE VALUE OF BITS DURING CONDITIONAL COMPILATION AND MACRO DEFINITION
VERSION 16-2(87) 11-30-72 BY RHT ADD LIBTAB ENTRIES FOR POLLING
VERSION 16-2(86) 11-28-72 BY RHT ADD CODE FOR CLEANUPS
VERSION 16-2(85) 11-24-72 BY RHT BUG #KM# TYPO MESSED UP POLISH FIXUP FOR EXT PD
VERSION 16-2(84) 11-21-72 BY JRL BAD JRST IN INMAIN
VERSION 16-2(83) 11-20-72 BY KVL REMOVE ER51 - MEANINGLESS MSG. IF YOU WANT IT, SEE ME.
VERSION 16-2(82) 11-19-72 BY HJS DLMPSH AND DLMPOP FOR PROPER HANDLING OF DEFINES WITHIN DEFINES
VERSION 16-2(81) 11-17-72 BY RHT ADD CALL TO USER INITIALIZATION
VERSION 16-2(80) 11-15-72 BY HJS INSERT DEFDLM QSTACK ROUTINES FOR DEFLUK BIT OF FF FOR COMPILE-TIME MACROS WITHIN MACROS
VERSION 16-2(79) 11-15-72 BY KVL SURPRESS CODE GENERATION AFTER SERIOUS ERRORS.
VERSION 16-2(78) 11-10-72 BY HJS ADD DLMSTG STACK SO MACROS DEFINED WITHIN MACROS WITH CONCATENATION WILL WORK
VERSION 16-2(77) 11-10-72 BY JRL ADD ERR MSG FOR PROPS AND LIBTAB ENTRIES
VERSION 16-2(76) 11-8-72 BY HJS IMPLEMENTATION OF CHECK!TYPE
VERSION 16-2(75) 11-7-72 BY JRL GIVE ERROR MESSAGE BAD USE OF BIND
VERSION 16-2(74) 11-2-72 BY RHT BUG #JY# TYPE CHECKING ON MEMORY INDEX
VERSION 16-2(73) 11-2-72 BY JRL ADD MAINPR TO LIBTAB
VERSION 16-2(72) 10-24-72 BY JRL ADD INMAIN EXEC TO INIT MAINPR
VERSION 16-2(71) 10-22-72 BY RHT BUG #JU# FIX UP ACKTAB ENCLOBERMENT BY QUICK!CODE
VERSION 16-2(70) 10-20-72 BY RHT BUG #JV# MEMORY TRIED TO USE AC 0 AS INDEX
VERSION 16-2(69) 10-20-72 BY RHT PROVIDE EXTRA ENTRY POINTS IN REQINI
VERSION 16-2(68) 10-17-72 BY AM HJS IMPLEMENTATION OF DECLARATION FEATURE FOR TYPE CHECKING AT COMPILE TIME
VERSION 16-2(67) 10-12-72 BY HJS BUG #JP# AND CVMS IMPLEMENTATION
VERSION 16-2(66) 10-10-72 BY KVL FIX ; ELSE RECOVERY
VERSION 16-2(65) 10-5-72 BY JRL PREPARE FOR EXPO
VERSION 16-2(64) 10-5-72 BY KVL MAKE UNDECLARED IDENTIFIERS AN ERR.
VERSION 16-2(63) 9-29-72 BY RHT BUG #JH# FIX TYPO IN REQINI
VERSION 16-2(62) 9-27-72 BY HJS FORCE EXECUTION OF BLOCK WHEN A DEFINE IS THE ONLY DECLARATION IN THE BEGINNING OF A BLOCK.
VERSION 16-2(61) 9-27-72 BY RHT BUG #JF# MESSAGE PROC LINK GETTING WRONG ADDRESS
VERSION 16-2(60) 9-27-72 BY JRL ADD ARYSET,SAFSET EXECS FOR DATUMS
VERSION 16-2(59) 9-25-72 BY RHT BUG #IZ# GLOBAL STUFF SHOULD STAY OUT OF PD
VERSION 16-2(58) 9-22-72 BY RHT BUG #IV# UNDEC FWRD MESSAGE PROC PD BUG
VERSION 16-2(57) 9-21-72 BY RHT MAKE THE LOCN PUT THING INCOR
VERSION 16-2(56) 8-24-72 BY RHT ADD CAUSE & INTERROGATE TO XCALL TABLE
VERSION 16-2(55) 8-23-72 BY JRL ADD BEXIT CODE FOR CONTEXT
VERSION 16-2(54) 8-22-72 BY RHT PREVENT DOUBLE ALLOCATION OF KILL SET
VERSION 16-2(53) 8-18-72 BY JRL CHANGE TYPPRO TO HANDLE MATCHING PROCEDURES
VERSION 16-2(52) 8-14-72 BY RHT EXEC FOR LOCATION(X)
VERSION 16-2(51) 8-14-72 BY RHT EVAL NOW NAMED APPLY
VERSION 16-2(50) 8-14-72 BY RHT ADD EXECS FOR MEMORY
VERSION 16-2(49) 8-11-72 BY RHT MAKE POLISH FIXUP TO GET AT EXTERNAL PD'S
VERSION 16-2(48) 8-11-72 BY JRL ADD REMEMBER ETC TO LIBTAB
VERSION 16-2(47) 8-4-72 BY RHT BUG #IT# EXTERNALS IN THE PD
VERSION 16-2(46) 8-1-72 BY RHT MAKE KILL SETS REAL SETS
VERSION 16-2(45) 7-28-72 BY RHT CHANGE FORKER TO SPROUT
VERSION 16-2(44) 7-26-72 BY HJS TURN OFF MACRO EXPANSION WHEN SCANNING FORMAL PARAMETERS.
VERSION 16-2(43) 7-25-72 BY RHT FIX THE PD SYMBOL
VERSION 16-2(42) 7-24-72 BY RHT PUT FORKER IN LIST OF XCALLED FNS
VERSION 16-2(41) 7-24-72 BY RHT PUT OUT SYMBOL FOR PD
VERSION 16-2(40) 7-22-72 BY RHT ADD KILL LISTS
VERSION 16-2(39) 7-9-72 BY RHT NO PD IF NO DADDY
VERSION 16-2(38) 7-5-72 BY DCS BUG #II# DON'T LET DEFINES OUT AS SYMBOLS
VERSION 16-2(37) 7-2-72 BY JRL SET LEAPIS IF ANY LEAP FUNCTIONS USED
VERSION 16-2(36) 6-25-72 BY DCS BUG #HX# PARAMETERIZE OPCODE FILE NAMES (AND OTHERS)
VERSION 16-2(35) 6-21-72 BY RHT CHANGE WAY PDA,,0 SEMBLK IS LINKED
VERSION 16-2(34) 6-14-72 BY JRL BUG ##H#S# STRING ITEMVAR PROCS ARE NOT STRING PROCS.
VERSION 16-2(32) 6-8-72 BY RHT MAKE ENTRY IN LIBTAB FOR EVAL
VERSION 16-2(31) 5-16-72 BY RHT GIVE ERR IF SIMPLE PROC ALLOCATES
VERSION 16-2(30) 5-16-72 BY RHT TO HANDLE OWN VARS IN BLOCKS--ENTID
VERSION 16-2(29) 5-14-72 BY DCS BUG #HH# BETTER INITIAL CODE IF /H
VERSION 15-6(7-28) 4-20-72 LOTS OF THINGS
VERSION 15-2(6) 2-21-72 BY HJS THE BRAVE NEW PARSER WORLD
VERSION 15-2(5) 2-6-72 BY DCS BUG #GN# UUOS TO START!CODE TABLE, FIX BOUNDARY COND.
VERSION 15-2(4) 2-5-72 BY DCS BUG #GJ# ADD LSTON LISTING CONTROL STUFF
VERSION 15-2(3) 2-5-72 BY DCS BUG #GI# ADD CAT ROUTS TO LIBFSN (CHRCAT, ETC.)
VERSION 15-2(2) 2-1-72 BY DCS ISSUE NEW STYLE %ALLOC SPACE REQUESTS
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
⊗;
LSTON (GEN)
BITD2DATA (EMITTER)
; EMITTER BITS -- PUT DESCRIPTORS IN POSITION TO BE EXAMINED BY $L OPERATIONS
↑GENBTS:
BIT (NOUSAC,400000) ;DON'T USE D(RH) AS AC #
BIT (USCOND,200000) ;USE C(RH) AS 3 BITS OF CONDITION
BIT (USADDR,100000) ;USE C(LH) AS DISPLACEMENT PART
BIT (USX , 40000) ;USE D(LH) AS INDEX REG
BIT (NORLC , 20000) ;RELOCATE NOT!
BIT (IMMOVE, 10000) ;IF OPERAND CONSTANT, LOAD IT ANY WAY POSSIBLE
BIT (INDRCT, 4000) ;INDIRECT ADDRESSING REQUIRED
BIT (JSFIX , 2000) ;JUST DO A FIXUP (DON'T GET SEMANTICS).
BIT (NOADDR, 1000) ;NO EFFECTIVE ADDRESS PART
BIT (EMADDR,400) ;WE WANT THE ADDRESS OF THIS ENTITY
BIT (PNTROP, 200) ;INTERNAL OPERATION INDICATING POINTER INDEXING
BIT (FXTWO, 100) ;USE SECOND FIXUP WORD
BLOCK 6 ;LEFT OVER BITS
BITD2DATA (GENMOV)
;CONTROL BITS PASSED TO GENMOV IN THE RIGHT HALF OF "FF".
;FOR COMMENTS, SEE THE FILE "TOTAL".
BIT (INSIST,400000) ;INSIST ON DOING TYPE CONVERSION.
;THE RIGHT HALF OF "B" CONTAINS TYPE BITS.
BIT (ARITH,200000) ;INSIST ARGUMENT IS AN ARITHMETIC TYPE.
BIT (EXCHIN,100000) ;DO AN EXCHOP ON THE WAY INTO THE ROUTINE.
BIT (EXCHOUT,40000) ;DO AN EXCHOP ON THE WAY OUT OF A ROUTINE.
BIT (GETD,20000) ;DO A GETAD BEFORE DOING THIS ROUTINE.
BIT (SPARE,10000) ;NEGAT←← 10000 ;GET THE OPERAND IN NEGATIVE FORM.
BIT (POSIT,4000) ;INSIST ON THE OPERAND IN POSITIVE FORM.
BIT (BITS2,2000) ;UPDATE SBITS2 FROM $SBITS2(PNT2) ON WAY OUT.
BIT (MRK,1000) ;MARK THE ACCUMULATOR MENTIONED IN D WITH THE ARGUMENT.
;(DONE AT END OF MAIN OPERATION)
;THIS MEANS "GENERATE A TEMP CELL IF NECESSARY."
BIT (ADDR,400) ;SAME BIT AS GENERATOR USES. USE THE ADDRESS OF ARG.
BIT (REM,200) ;REMOP ON THE WAY OUT.
BIT (NONSTD,100) ;NON-STANDARD OPERATION.
BIT (SPAC,40) ;WE HAVE A SPECIFIC AC NUMBER IN MIND.
BIT (PROTECT,20) ;PROTECT THIS ACCUMULATOR.
BIT (UNPROTECT,10) ;UNPROTECT THIS ACCUMULATOR.
BIT (DBL,2) ;NEED A DOUBLE ACCUMULATOR.
BIT (INDX,1) ;NEED AN INDEXABLE ACCUMULATOR.
BITDATA (STROP)
; BITS TO BE PASSED TO STROP IN A
; SEE STROP FOR MEANINGS OF THESE BITS.
?BPWORD ←← 400000
?LNWORD ←← 200000
?BPFIRST ←← 100000
?ADOP ←← 40000
?SBOP ←← 20000
?UNDO ←← 10000
?STAK ←← 4000
?BPINC ←← 2000
ZERODATA (EXEC ROUTINES -- GLOBAL VARIABLES)
COMMENT ⊗
ADEPTH -- Whenever code is generated to push something onto the
System stack (P, usually 17), currently only when an actual
parameter is put on, this is incremented. It is added to
the displacement for a formal parameter whenever it is ref-
erenced. This allows the access code to get to the right
stack element for a parameter, no matter what's on the stack.
ADEPTH is decremented when things come off. It is restarted
whenever a procedure declaration is encountered (first checked,
since it should always be 0 at that point).
⊗
?ADEPTH: 0
;APARNO -- a count of the number of non-string parameters in
; the current procedure -- used to set up the $NPRMS word
; in the 2d Semblk for the procedure
?APARNO: 0
;DEFRN1 -- Semantics of first formal macro param in VARB-Ring
; while scanning macro params. Used to release all the
; Semblks for these params when done with them.
?DEFRN1: 0
COMMENT ⊗
FALLOC -- Semantics of a [0] integer constant, created the
first time the word FALSE appears in source -- FALSE
thenceforth equated to this [0] constant, since the two
are internally equivalent -- see BFAL routine
⊗
?FALLOC: 0
;GLOBCNT -- used in ENTID to count # global items declared
?GLOBCNT: 0
;LENCNT -- AOS'ed whenever substring operation is begun, SOS'ed
; when it is complete. BINF (INF same as length(str) EXEC) checks
; this to make sure there's a string to take the length of.
?LENCNT: 0
;LENSTR -- QSTACK descriptor -- each entry is Semantics of a
; string being SUBSTRd. Kept here for convenience of BINF,
; so that it doesn't have to search up the stack for it.
?LENSTR: 0
;NULLOC -- Semantics of "", for BNUL (NULL equivalent to "" EXEC)
?NULLOC: 0 ;SEE FALLOC, TRULOC
;OPCODE -- for binary operations, proper opcode (and control bits),
; fetched from one of the OP tables (PMTAB, TDTAB, MXMNTB) via the
; class code in the production which called the EXEC. Used as tem-
; plate for output instruction. Stored in OPCODE for convenience
?OPCODE: 0
;SDEPTH -- ADEPTH-type count for String stack -- bumped not only for
; actual params, but also for String Procedure results, other
; String operations which use the stack.
?SDEPTH: 0
;SPARNO -- APARNO-type count of String formals -- it's possible that
; this is doubled before use, since there are two words for each
; String descriptor. See PROCED, ENTID for uses.
?SPARNO: 0
;THISE -- Set by ECHK EXEC, remembers type of expression, since two
; class codes are passed in from PARSER
; (e.g., EXEC @E ECHK @class randomexec)
?THISE: 0
;TRULOC -- Semantics of [-1], used by BTRU (TRUE equivalent to ≠0 EXEC)
?TRULOC: 0
TABLEDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
COMMENT ⊗
LIBTAB -- table of fixups (current ends of chains) for routines
called by SAIL programs to accomplish complicated operators
(CAT, SUBSTR, ARRMAK, etc.) -- the LIBFSN macro, with the
appropriate definition of the FN macro, puts out a symbolic
index into this table for each name mentioned (R&ROUTNAME),
and a word of table to hold the fixup. It is used again below
(LIBNAM) to create a table of corresponding External RADIX50
request words which will be used in DONES to put out the chain
requests. The XCALL and LPCALL macros are used to put out
(fixup chained) calls to these routines.
⊗
DEFINE LIBFSN <
FN <CAT> ;STRING CONCATENATIONS.
FN <CHRCAT> ;INTEGER&STRING
FN <CATCHR> ;STRING&INTEGR
FN <CHRCHR> ;INTEGR&INTEGR
FN <CAT.RV> ;STRING&STRING, 2D ARG FIRST
FN <SUBSR> ;SUBSTRING (FOR)
FN <SUBST> ;SUBSTRING (TO)
; FN <SUBSI> ;EXTINCT (USED TO BE SUBSTRING INF)
FN <GETCH> ;CONVERT FIRST CHAR OF STRING TO INTEGER
FN <PUTCH> ;CONVERT LOW ORDER 7 BITS TO STRING
FN <POW> ;EXPONENTIATION
FN <FPOW> ;FLOATING ARG, INTEGER EXPONENT.
FN <LOGS> ;INTEGER ARG,FLOATING EXPONENT.
FN <FLOGS> ;FLOATING ARG, FLOATING EXPONENT.
FN ($PDLOV) ;THIS IS HOW TO CAUSE PDLOV UNDER SKIPL
FN <ARMRK> ;MARK THE ARRAY PUSHDOWN STACK.
FN <ARMAK> ;MAKE AN ARRAY (PARAMS IN STACK)
FN <ARREL> ;RELEASE ARRAYS BACK TO LAST MARK ON STACK.
FN <LEAP> ;CALL LEAP!
FN <DATM> ;THIS IS REF TO A WORD WHICH IS XWD 3, ptr to
; BASE OF DATUM TABLE.
FN <LPRYER> ;DATUM(X) WAS NULL, WHEN AN ARRAY WAS EXPECTED.
FN <PROPS> ;THE PROPS BYTE POINTER POINT 9,INFOTAB(3),35
GLOC <
FN <GPROPS> ;GLOBAL PROPS
FN <GDATM> ;GLOBAL DATUM
FN <.MES1>
FN <.MES2>
FN <DATERR>
>;GLOC
FN <PITBND> ;BIND PD TO ITEM
FN <PITCOP> ;COPY PROC ITEM
FN <PITDTM> ;-1(P)←DATUM(-1(P))
FN <APPLY> ;INTERP CALLER
FN <SPROUT> ;SPROUTER
FN <CAUSE> ;CAUSES EVENTS
FN <INTERROGATE> ;INTERROGATE FUNCTION
FN <MAINPR> ;INITIALIZE PROCESSES
FN <BEXIT> ;BLOCK EXITER
FN <STKUWD> ;STACK UNWINDER
FN <CSERR> ;CASE STATEMENT INDEX OUT OF BOUNDS
FN <ALLRM> ;REMEMBER ALL
FN <ALLFOR> ;FORGET ALL
FN <ALLRS> ;RESTORE ALL
FN <REMEMB> ;REMEMBER
FN <FORGET> ;FORGET
FN <RESTOR> ;RESTORE
FN <.INCON> ;IN!CONTEXT
FN <CONELM> ;C:VAR
FN <.SUCCE> ;SUCCEED (FOR MATCH. PROCS)
FN <.FAIL> ;FAIL
FN <.UINIT> ;USER INITIALIZATIONS
FN <DDFINT> ;DO DEFERED INTERRUPT
FN <INTRPT> ;SET ≠0 WHEN HAVE AN INTERRUPT
FN <APPL$Y> ;USED WITH SPROUT APPLY
FN <SETIP> ;
FN <SETCP> ;
FN <WR_TON> ;WRITEON RUNTIME
REC < FN <$RERR> ;RECORD ACCESS ERROR
FN <$REC$> ;SYSTEM RECORD HANDLER
>;REC
>
DEFINE FN '(X) <
?R'X ←← LIBNUM
?LIBNUM ←← LIBNUM+1
0 ;FIXUP WORD.
>
?LIBNUM←←0
?LIBTAB: LIBFSN ;FIXUPS FOR LIBRARY FUNCTIONS.
; the current procedure -- used to set up the $NPRMS word
TABCONDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
COMMENT ⊗
LIBNAM -- these are the external request symbols for the
above-mentioned runtime routines -- see LIBTAB, above
⊗
DEFINE FN (X) < RADIX50 60,X >
LIBNAM: LIBFSN
>
COMMENT ⊗
TYPTAB, VALTAB, XOTAB
These tables are used by the TYPSET, VALSET, XOWSET routines
to convert the class codes from the PARSER, specifying which
data type, REFERENCE or VALUE type, or modifier (SAFE, etc.)
is being requested, to the appropriate TBITS bit. These three
routines are, as might be guessed, EXEC routines.
⊗
↑TYPTAB:
HELITM: ITEM ;ITEM
HELITV: ITMVAR ;ITEMVAR
0+SET ;SET
LABEL+FORWRD ;LABEL
FLOTNG ;REAL
INTEGR ;INTEGER
STRING ;STRING
INTEGR ;BOOLEAN
0+SET+LSTBIT ;LIST
XWD SAFE,SET!INTEGR ;KILL!SET
0+SET!FLOTNG ;CONTEXT
XOTAB: XWD INTRNL,0 ;INTERNAL
XWD SAFE,0 ;SAFE
XWD EXTRNL,0 ;EXTERNAL
XWD OWN,0 ;OWN
XWD RECURS,0 ;RECURSIVE
XWD EXTRNL,FORTRAN ;FORTRAN
FORWRD ;FORWARD
SHORT ;SHORT
XWD SIMPLE,0 ;SIMPLE
XWD MPBIND,INTEGR ;MATCHING
GLOC <
GLOBL ;GLOBAL LEAP TYPE.
XWD MESSAGE,0 ;MESSAGE
>;GLOC
NOGLOC <
0 ;TURN ON NO BITS IF NOT GLOBAL
0 ;COMPILER....
>;NOGLOC
VALTAB: XWD REFRNC,0 ;REFERENCE
XWD VALUE,0 ;VALUE
XWD VALUE!MPBIND,ITMVAR ;? PARAMETER
CHKTAB: XWD RES,0 ; RESERVED
XWD BILTIN,0 ; BUILTIN FUNCTION
LPARRAY ; LEAP ARRAY
XWD SBSCRP,0 ; NORMAL ARRAY
XWD DEFINE,0 ; DEFINE
PROCED ; PROCEDURE
ENDDATA
SUBTTL EXEC (GENERATOR) INITIALIZATION
DSCR GENINI
CAL PUSHJ from SAIL Exec
RES Initializes variables for whom the EXECS (generators)
have main responsibility. Calls RELINI and LEPINI to set
up Relfile and Leap variables
SEE SAIL Exec, RELINI, LEPINI
⊗
↑GENINI:
;;%AL% ! STARTUP SEQUENCE IS ONE SHORTER
II←←7 ;LONGER STARTUP
;* * * * * *
REN <
SETOM INHIGH ;WILL BE IN HIGH FIRST IF HISW
MOVEI TEMP,1
MOVEM TEMP,HCNT ;DATA STARTS AT 1 IF HISW
>;REN
MOVEI TEMP,II ;START HERE
REN <
SKIPE HISW ;TWO-SEGMENT COMPILATION?
MOVEI TEMP,400000+II ;YES, CODE STARTS HERE
>;REN
MOVEM TEMP,PCNT
;;#HH# 5-14-72 DCS (2-2) ACCOUNT FOR UPPER SEGMENT CODE
REN <
MOVEI TEMP,5-II(TEMP) ;NOW ADJUST INITIAL PD PUSH DATA
HRRM TEMP,IPDFIX ;SEE SAIL FOR THIS ARCHBLOCK
>;REN
;;#HH# (2-2)
Comment ⊗ The first words of code are (for main programs)
0 SKIPA ;NON-RPGMODE START
1 SETOM RPGSW ;RPG MODE
2 JSR SAILOR ;INITIALIZE
3 HRLOI RF,1 ;FOR FAKE F LINK
4 PUSH P,RF
5 PUSH P,[PDA,,0] ;PDA OF OUTER BLOCK & USELESS STATIC LINK
6 PUSH P,SP ;REST OF MSCP
7 HRRZI RF,-2(P) ;POINT THERE
⊗;
; MARK TOP AC'S UNUSABLE FOR GENERAL ALLOCATION
FOR II IN (RSP,RP,USER,TEMP,LPSA,RF) <
SETOM ACKTAB+II>
; ***** THIS CODE MOVED TO RELOUTPUT AREA IN TOTAL
PUSHJ P,RELINI ;INITIALIZE LOADER FILE VARIABLES
; *****
;No RAID on TENEX and $M causes UNDEF GLOBAL loading errors
NOTENX <
IFN FTDEBUG <
MOVE TEMP,BITABLE
EXTERNAL $M
MOVEM TEMP,$M+3 ;RAID LOC
>;IFN FTDEBUG
>;NOTENX
; ***** THIS CODE MOVED TO LEAP
PUSHJ P,LEPINI ;INITIALIZE LEAP VARIABLES
; ******
POPJ P,
REN <
DSCR HISET, LOSET, SWIT -- Call to Get Correct PCs into PCNT and HCNT
DES Calling HISET makes sure code will go to upper segment.
Calling LOSET makes sure it will go to lower segment
Calling SWIT does HISET if LOSET was last, LOSET if HISET was last.
⊗
↑HISET: SKIPE INHIGH ;ALREADY IN HIGH SEGMENT?
POPJ P, ;YES, DONE
JRST SWIT ;NO, GO IN
↑LOSET: SKIPE INHIGH ;ALREADY IN LOW SEGMENT OR
↑SWIT: SKIPN HISW ; IS THIS RELEVANT?
POPJ P, ;YES OR NO
SETCMM INHIGH ;IF IN, NOW OUT AND VICE VERSA
PUSHJ P,FRBT ;FORCE OUT BINARY IN OTHER SEGMENT
MOVE TEMP,PCNT ;EXCHANGE PCS
EXCH TEMP,HCNT
MOVEM TEMP,PCNT
POPJ P, ;DONE
>;REN
DSCR GETOP, GETADL, GETAD
DES Routines to pick things up from symbol table blocks.
GETOP is the entry which also picks up the
generator stack entry specified by accumulator A.
⊗
↑GETAD2: SKIPN PNT2
ERR <DRYROT -- GETAD>
MOVE SBITS2,$SBITS(PNT2)
MOVE TBITS2,$TBITS(PNT2)
POPJ P,
↑GETAD: JUMPN PNT,GETSTF ;TEST FOR NULL SEMANTICS.
ERR <DRYROT -- GETAD>
↑GETADL: SKIPN PNT,LPSA ;MAKE SURE WE HAVE A GOOD ENTRY
ERR <DRYROT -- GETAD>
GETSTF: MOVE SBITS,$SBITS(PNT)
MOVE TBITS,$TBITS(PNT) ;BOTH BITS WORDS
POPJ P,
BEGIN GENDEC
SUBTTL EXECS for typing variables, equating TRUE with -1, etc.
DSCR -- SAIL DECLARATION EXECS
DES These are the declarations routines.
They take care of simple identifier declarations
as well as procedures, arrays, etc. If a "BEGIN"
is seen, the varb structure recurrs out of the current
block, a new one is created, the VARB list is updated to the
new block, and a new symbol table bucket is made.
The reverse is effected when an "END" is seen which
matches a BEGIN which involved declarations.
For procedures, a similar thing happens.
⊗
DSCR TYPDEC, TYPAR, TYPPRO, etc.
PRO TYPDEC TYPAR TYPPRO TYPR1 PRST
DES The routines to "type" an entity and return an appropriate
parser token. Thus, the parser can be aware of the types of
user identifiers. This speeds up operations somewhat, and means
that the parser can do much of the "semantic" type-checking.
⊗
↑TYPDEC: HRLI A,CLSIDX ;ALL VARIABLES ARE CLASS MEMBERS
TLNE TBITS,CNST ;a constant ?
JRST MYCON
TLNE TBITS,SBSCRP ;ARRAY?
JRST ARLO ;YES
TRNE TBITS,ITEM+ITMVAR+PROCED
JRST TYPDES ;DESCRIMINATE
HRRI A,TICTXT
TRNE TBITS,FLOTNG
TRNN TBITS,SET
CAIA
POPJ P,
HRRI A,TIST ;SET
TRNE TBITS,SET
POPJ P,
REC <
TRNE TBITS,PNTVAR ;CHECK FOR RECORD CLASS ID
TRNN TBITS,SHORT ;CLASS IS SHORT PNTVAR
JRST .+3 ;NOPE
HRRI A,TIRC ;IT IS A RECORD CLASSID
POPJ P,
>;REC
HRRI A,TIVB
NOREC <
TRNE TBITS,INTEGR+FLOTNG+DBLPRC
>;NOREC
REC <
TRNE TBITS,INTEGR+FLOTNG+DBLPRC+PNTVAR
>;REC
POPJ P,
HRRI A,TISV ;STRING VARIABLE
TRNE TBITS,STRING
POPJ P,
HRRI A,TILB ;LABEL
TRNE TBITS,LABEL
POPJ P,
TROUBL: HRRI A,TI ;UNDECLARED IDENTIFIER
POPJ P,
TYPDES: HRRI A,TIPR ;PROCEDURE
TRNE TBITS,PROCED
POPJ P,
HRRI A,TIIT ;ITEM
TRNE TBITS,ITEM
POPJ P,
HRRI A,TITV ;ITEMVAR
TRNE TBITS,ITMVAR
POPJ P,
JRST TROUBL
ARLO: HRRI A,TIAR ;ARITHMETIC OR ITEM ARRAY.
POPJ P, ;ARITHMETIC OR ITEM ARRAY
MYCON: HRRI A,TICN ;ARITHMETIC CONTSTANT
TRNE TBITS,STRING ;MIGHT BE STRING
HRRI A,TSTC ;STRING CONSTANT.
POPJ P,
↑TYPAR: ;TYPE AN ARRAY
↑TYPPRO: TDZA B,B ;INDEX INTO GENRIG,PARIG
↑TYPR1: MOVEI B,1
SKIPN LPSA,GENRIG(B) ;SEMANTICS
ERR <UNTYPED PROCEDURE AS EXPRESSION>,1,<[TRO TBITS,INTEGR
JRST TYPESS]>
TYA1: PUSHJ P,GETADL ;GET GOOD BITS
TLNE TBITS,MPBIND ;MATCHING PROCEDURE
TLNN FF,LPPROG ;AND FOREACH IN PROGRESS
CAIA
POPJ P,
TRZ TBITS,PROCED ;TURN OFF PROCEDURE
TLZ TBITS,-1
TRNN TBITS,ALTYPS ;ANYTHING THERE?
TYPER: JRST [HRLI A,CLSIDX ;WE FAKE AN INTEGER
HRRI A,TIVB
JRST TYPESS]
PUSHJ P,TYPDEC ;TYPE BIT
TYPESS: MOVEM A,PARRIG(B) ;PUT DOWN THE ANSWER
POPJ P,
↑PRST: SKIPN PNT,GENRIG
POPJ P, ;PROCEDURE WAS UNTYPED....
MOVE TBITS,$TBITS(PNT) ; TYPE.
;;#HS# JRL 6-14-72 A STRING ITEMVAR IS NOT A STRING
TRNE TBITS,ITMVAR!ITEM
JRST REMOP
;;#HS#
REC <
NORGC <
TRNE TBITS,PNTVAR ;A RECORD PROCEDURE??
JRST [ EMIT <RECUUO 0,NOUSAC>
JRST REMOP ] ;DEREFERENCE IT
>;NORGC
>;REC
TRNE TBITS,STRING ;IF OF TYPE STRING, COMPLAIN.
JRST SUBIT ;DOWN IN TOTAL -- SUBTRACTS FROM STACK.
JRST REMOP
DSCR TYPSET, VALSET, XOWSET, etc.
PRO TYPSET XOWSET VALSET HELAR2 HELAR1 HELARY CLRSET PRSET
DES EXECS to collect type bits as they are specified
The standard mechanisms for entering variables.
Little routines are called to turn on the right bits
in the "BITS" word for ENTERS to eventually use
⊗
;RECORD ANY MODIFIERS ON THE DECLARATIONS.
;CALLED WITH CLASS INDEX TYPE IN REGISTER B.
↑XOWSET: SKIPA A,XOTAB(B) ;PICK UP TABLE ENTRY
↑VALSET: MOVE A,VALTAB(B) ;INDEXED BY "B" PASSED FROM PARSER
IORM A,BITS
POPJ P, ;RETURN
↑ARYSET: SKIPA A,[LPARRAY]
↑SAFSET: MOVEI A,SAFE ;SAFE BIT
IORM A,BITS ;SAVE IT
POPJ P,
↑HELAR2: MOVE B,BITS
;; #KU# DON'T MAKE ARRAY ITEMS OWN
TRO B,ITEM ;SO HELSPC WILL KNOW NOT TO MAKE OWN
PUSHJ P,HELSPC ;SPECIAL FOR ARRAY ITEMS.
TDZA B,B ;ITEM .......
↑HELAR1: MOVEI B,1
↑HELARY: MOVEI A,LPARRAY ;SAY A LEAP TYPE ARRAY.
IORM A,BITS ;AND FALL THROUGH TO TYPE IT.
↑HELSET:
↑TYPSET: MOVE A,TYPTAB(B) ;ORDINARY TYPES.
IORB A,BITS
MOVEM A,ARYBIT ;AND RECORD SHOULD AN ARRAY BE DECLARED.
POPJ P,
↑CLRSET: SETZM BITS ;ZERO FOR A NEW TYPE
REC <
SETZM QRCTYP
SETZM URCIPR
SETZM RCLASS
>;REC
POPJ P,
↑PRSET: MOVEI A,PROCED
IORM A,BITS
POPJ P,
; ******
; STARY, ENTARY, Array declaration routines, were moved to ARRAY code
; ****** 11/24/70
MOVEM A,PARRIG(B) ;PUT DOWN THE ANSWER
DSCR TCON, BTRU, BFAL, BNUL, BINF
PRO TCON
DES kludges to make TRUE, FALSE, NULL, and INF work right
TRUE canonically -1, so a constant is created (once), and Semantics rtnd
FALSE equivalent to 0
NULL equivalent to ""
INF same as LENGTH(innermost String being SUBSCRd -- else error)
⊗
↑TCON: JRST .+1(B) ;CALL CORRECT ROUTINE.
JRST BINF ;INF OPERATOR.
JRST BNUL ;NULL
↑BTRU: SKIPA C,[XWD -1,TRULOC]
↑BFAL: MOVEI C,FALLOC
PUSHJ P,GETITC ;GET THE CONSTANT.
RETRT: MOVEM PNT,GENRIG
POPJ P,
↑BTRU1: HRROI C,TRULOC ;FOR TRUE
GETITC: SKIPE PNT,(C) ;IS THERE A VALUE ALREADY??
POPJ P, ;YES -- RETURN IT.
PUSH P,BITS
HLRE A,C ;THIS IS 0 OR -1
PUSHJ P,CREINT
MOVEM PNT,(C)
POP P,BITS ;RESTORE
POPJ P,
↑BNUL: SKIPE PNT,NULLOC
JRST RETRT
PUSH P,BITS
PUSH P,PNAME
PUSH P,PNAME+1
SETZM PNAME+1
SETZM PNAME
PUSHJ P,STRINS
MOVEM PNT,NULLOC
POP P,PNAME+1
POP P,PNAME
POP P,BITS
JRST RETRT
↑BINF: SKIPN LENCNT ;ARE WE INSIDEA SUBSTRING OPERATION??
ERR (<INF (infinity) INVALID, 0 ASSUMED>,1,BFAL)
HLRZ A,LENSTR ;LEFT HALF POINTS TO TOP OF QPUSH STACK.
SKIPGE A,(A) ;NEG IF INF. WITHIN SUBLIST SELECTOR
JRST LINF ;LIST INFIN. LOCATED IN LEAP
MOVEM A,GENLEF+1 ;SET UP FOR LENGTH
JRST LLEN1 ;MODIFIED FORM OF LENGTH.
DSCR TWID10, ECHK, ESET
PRO TWID10, ECHK, ESET
DES The "TWIDDLERS" which craftily manipulate the semantics
stack entries. They are used to move things around when
no other generators need be called, or when convenience warrents.
⊗
↑TWID10: MOVE A,GENLEF+1 ;THIS MOVES FROM ENTRY 1
MOVEM A,GENRIG ;TO ENTRY 0.
POPJ P, ;EXAMPLE -- PRODUCTION "XID"
;NOW FOR THE GENERALIZED EXPRESSION CHECKER. PASSED IS AN INDEX....
↑ECHK: JRST @.+1(B) ;GO DO RIGHT THINGS.
JRST CPOPJ ;REGULAR ARITH EXPRESSION.
JRST LEVBOL ;BOOLEAN EXPRESSION .. CONVERT TO INTEGER.
JRST LEAVE ;ASSOCIATIVE EXPR. -- CONVERT TO ITEM ..
; SAVE CLASS INDEX FOR PRODUCTIONS WHICH REFER TO TWO (FIRST)
↑ESET: MOVEM B,THISE ;SAVE INDEX IF THIS CLASS
POPJ P, ;HARDLY WORTH THE CALL
; (SHOULD HAVE WRITTEN?)
DSCR FDO1, FDO2
PRO FDO1 FDO2
DES LEAP function calling routines -- dipatch on class
to proper LEAP routine.
⊗
↑FDO1: JRST @.+1(B)
JRST ISTRIP ;ISTRIPLE
JRST SLOP ;STRING LOP
JRST ECVN ;CVN
JRST [SKIPN PNT,GENLEF+1
JRST STCNT
MOVE TBITS,$TBITS(PNT)
TRNN TBITS,STRING!INTEGR
JRST STCNT ;LENGTH OF SET.
JRST LLEN ;STRING LENGTH
]
REPEAT 2 ,<JRST BYPE> ;BYTE POINTER THINGS.
↑FDO2: JRST @.+1(B)
SELET
SELET
SELET ;FIRST,SECOND,THIRD
STUNT ;COP
ECVI ;CVI
SUBTTL EXECS for Handling Block Levels, Entering Variables
DSCR DWN, BLOCK, BLNAME, ENTID, UP, NAMCHK, etc.
PRO DWNA DWN BLOCK BLNAME ENTID ENDDEC UP1 UP2 NAMCHK UPWOM
DES These EXECS handle the declarations of a Block, from
recursion of lexical state at BEGIN and END, to the actual
entry of locals, to the checking of Block names.
SEE comments following this DSCR for more information.
⊗
Comment ⊗
These are the routines to process the entering and leaving of lexical levels.
DWN is called when a BEGIN is seen. It merely clears the boards in case
some declarations come along.
BLOCK is called if it develops that this block is going to have declarations.
The lexical level is incremented, and a new hash bucket is made.
The block entry in the semantic stack is flagged as "declarations
done in this block".
BLNAME is called if the block is going to have a name. This is independent
of whether it has declarations or not. If there are no declarations,
this is merely the name of a compound block.
ENTID is called to enter identifiers in the block. It basically calls
ENTERS. But there is a lot of bookkeeping to do -- allocate
item numbers, flag the block if arrays are declared, etc.
ENDDEC is called when all declarations are done. This puts out an
ARMRK if arrays were declared, etc.
UP1 or UP2 is called when the block is exited.
The block header is placed in a "block list" which is scanned
at allocation time (end of procedure). Symbols, etc. are
put out at that time.
NAMCHK is called to check to see if the respective BEGIN END pairs have
corresponding names.
PACDO is called to protect acs for the duration of the block
⊗
;COME HERE WHEN YOU SEE A BEGIN
↑DWN: SETOM NODFSW ; SET FLAG TO DEFER PROCESSING OF DEFINES
; UNTIL A BLOCK HAS BEEN EXECUTED.
↑DWN1: SETZM BITS ;IN CASE A CONSTANT WAS ENTERED
SETZM GENRIG+1
;WHILE WE WERE AWAY!!!
BAIL<
SKIPLE BAILON
PUSHJ P,BCROUT ;A NEW COORDINATE FOR EACH BEGIN
SETZM BPPCNT ;FORCE A COORDINATE OUT NEXT TIME
>;BAIL
POPJ P, ;ALL DONE
↑OFFDEF: SETZM NODFSW ; TURN OFF FLAG WHICH DEFERS THE PROCESSING
POPJ P, ; OF DEFINES UNTIL A BLOCK HAS BEEN
; EXECUTED.
↑BLOCK: SETZM NODFSW ; TURN OFF FLAG WHICH CAUSES THE DEFERMENT
; OF DEFINE PROCESSING.
AOS LEVEL
REC <
QPUSH (RCLPDL,[-1]) ;MARK THE REC CLASS LIST PDL
>;REC
MOVE A,VARB ;SAVE OLD CONTENTS.
SETZM VARB ;RESTART VARB.
SKIPN LPSA,GENLEF+1 ;"BLOCK" BLOCK THERE?
GETBLK ; NO -- GET ONE.
SKIPN QQFLAG ;IS THIS THE FIRST BLOCK WITH DECL'S?
HRRZM LPSA,QQBLK ;YES, STORE IT FOR UNDEC
SETOM QQFLAG
;**** QQFLAG WILL HAVE TO BE INCLUDED IN THE INITIALZATION CODE EVENTUALLY****
BAIL<
SKIPG BAILON
JRST YESBB
;;# # (1 OF 2) JFR 9-29-74 SAVE AC A OVER THIS MESS
PUSH P,A
;;# #
HLRZ TEMP,%TLINK(LPSA)
JUMPN TEMP,BBNM01 ;JUMP IF SECOND BLOCK ALREADY THERE
PUSH P,LPSA ;FIRST BLOCK SEMBLK
GETBLK
MOVE TEMP,LPSA ;TEMP=SECOND BLOCK SEMBLK
POP P,LPSA ;LPSA=FIRST BLOCK SEMBLK
HRLM TEMP,%TLINK(LPSA) ;LINK SECOND TO FIRST
BBNM01: HRRZ TBITS,BCORDN ;COORDINATE NUMBER
HRRM TBITS,$VAL2(TEMP) ;STORE IN SECOND SEMBLK
MOVE TEMP,PCNT
HRLM TEMP,$VAL2(LPSA) ;SAVE ADDRESS OF FIRST WORD
;;#%%# DEFAULT NAME CREATION TRANSFERED TO BAISYM 11-7-74 JFR
SKIPN $PNAME(LPSA) ;ALREADY HAVE A NAME?
AOS NMLVL ;NO. UP A DDT LEVEL--NAME WILL BE GIVEN LATER
;;# # (2 OF 2) GET AC A BACK
POP P,A
;;# #
>;BAIL
YESBB:
HRROM LPSA,GENRIG+1 ;FLAG THAT DELCARATIONS HAVE BEEN DONE.
PUSHJ P,RNGVRB ;PUT ON THE VARB RING
HRL A,TTOP ;GET OLD TTOP
MOVEM A,$ADR(LPSA) ;SAVE TTOP,,VARB.
MOVEW (<$SBITS(LPSA)>,LEVEL) ;SAVE CURRENT LEVEL
HRRM LPSA,TTOP ;NEW ONE
HRRZ TEMP,NMLVL ;PICK IT UP HERE IN CASE BLNAME DOESN'T
HRRM TEMP,$VAL2(LPSA) ;AND STORE IT IN DDT LEVEL LOCATION
PUSHJ P,MAKBUK ;MAKE A NEW SYMBOL BCKET
MOVE LPSA,SYMTAB ; GET NEW BUCKET
MOVE TEMP,GENRIG+1 ; GET THE BLOCK
HRRM LPSA,%TBUCK(TEMP) ; STORE BUCKET FOR LATER HASH OF IDENTS
JRST SHASH ;HASH AGAIN GIVEN THE NEW BUCKET
↑CSNAME: TLO FF,FFTEMP ;NAMED CASE STATEMENT
SETZM BITS ;DUPLICATE INITIAL CODE
MOVE PNT,GENLEF ; BECAUSE
MOVE LPSA,GENLEF+1 ; WE ALREADY HAVE A CASE BLOCK
JRST FOXX ; LINK IT TO STRING RING AND CONTINUE
↑BLNAME: TLZ FF,FFTEMP ;NAMED BLOCK,CPD STMT
SETZM BITS
MOVE PNT,GENLEF ;POINTER TO NAME CONSTANT.
GETBLK <GENRIG> ;GET A BLOCK.
FOXX: PUSHJ P,RNGSTR ;PUT ON THE STRING RING
TLNE FF,FFTEMP ;CASE STMT?
JRST CSVER ;YES, NO LABEL ISSUED
BAIL<
SKIPG BAILON
JRST NBAI07
HLRZ TEMP,%TLINK(LPSA)
JUMPN TEMP,FOXX01 ;JUMP IF SECOND SEMBLK ALREADY THERE
PUSH P,LPSA
GETBLK
MOVE TEMP,LPSA ;TEMP=SECOND BLOCK SEMBLK
POP P,LPSA ;LPSA=FIRST BLOCK SEMBLK
HRLM TEMP,%TLINK(LPSA)
FOXX01: MOVE A,BCORDN
HRRM A,$VAL2(TEMP) ;REMEMBER COORD
NBAI07:
>;BAIL
AOS TEMP,NMLVL ;DDT (BLOCK NAME) LEVEL
HRL TEMP,PCNT ;LOCATION OF FIRST WORD
MOVEM TEMP,$VAL2(LPSA) ;STORE IN BLOCK BLOCK
CSVER: MOVEI A,$PNAME-1(LPSA)
PUSH A,$PNAME(PNT) ;RECORD NAME.
PUSH A,$PNAME+1(PNT)
TLNN FF,CREFSW ;CREFFING?
JRST NOCRW ;NO
MOVEI A,15
PUSHJ P,CREFOUT ;BLOCK NAME COMING.
PUSHJ P,CREFASC ;AND CREF THE ASCII NAME OF BLOCK.
NOCRW:
TLNN FF,FFTEMP ;CASE?
TLNN FF,TOPLEV ;AT TOP LEVEL?
POPJ P, ;NO
MOVEI LPSA,IPROC+$PNAME-1 ;PUT IN PROGRAM NMAE.
PUSH LPSA,$PNAME(PNT)
PUSH LPSA,$PNAME+1(PNT)
JRST MAKT ;MAKE A NEW PROGRAM HEADER.
↑PACDO: MOVE LPSA,GENLEF+1 ;PICK UP AC NO TO SAVE
MOVE D,$VAL(LPSA) ;
CAIL D,0
CAILE D,17
ERR <ATTEMPT TO PROTECT A NUMBER NOT AN AC: >,7
ANDI D,17 ;IN CASE THE FOOL CONTINUES
SKIPL B,ACKTAB(D)
JRST .+3
MOVE D,D ;FOR ERR UUO
ERR <ATTEMPT TO PROTECT SOMETHING ALREADY PROTECTED: 0>,7
PUSHJ P,STORZ ;CLEAR THE AC
HRROS ACKTAB(D) ;PROTECT IT
HRLZI A,1
;;#RN# ! USED TO BE -1(D)
LSH A,(D) ;ORING MASK
MOVE LPSA,TTOP
ORM A,$TBITS(LPSA) ;MARK BLOCK SEMBLK
MOVEI A,12
MOVEI B,4
CNT1FA: SKIPL ACKTAB(A)
SOJLE B,ENGHAC
SOJGE A,CNT1FA
ERR <NOT ENOUGH ACS LEFT UNPROTECTED>,1
ENGHAC: POPJ P,
↑ENTID:
ORDENT:
SKIPN PNT,NEWSYM
JRST ENWAY ;NOT DEFINED BEFORE
MOVE TBITS,$TBITS(PNT) ;GET CURRENT SEMANTICS
TLNE TBITS,CNST ;DON'T LET CONSTANTS THROUGH
ERR <DECLARING A CONSTANT -- CHECK MACROS>,1
TLNN FF,CREFSW ;ARE WE CREFFING?
JRST ENWAY ; NO
MOVEI A,7 ;DELETE PREVIOUS ENTRY.
PUSHJ P,CREFOUT
ENWAY:
GLOC <
SKIPN ALLGLO ;GLOBAL LEAP ONLY?
JRST ENWAY2 ;NO
MOVE A,BITS
TRNE A,ITEM ;ONLY ITEMS ARE AFFECTED
TRO A,GLOBL
MOVEM A,BITS
ENWAY2:
>;GLOC
PUSHJ P,ENTERS ;DO THIS FIRST!!
MOVE LPSA,NEWSYM
PUSHJ P,GETADL ;GET GOOD BITS
TLNE FF,PRODEF ;ARE WE SCANNING ID LIST
JRST IDLIS ; YES
MOVE A,[XWD SAFE,SET+INTEGR] ;CHECK ON KILL SET GUY
TDC A,TBITS
TDNE A,[XWD SAFE,SET+INTEGR] ;IS IT ??
JRST EN.W1 ;NO
TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR!PROCED]
ERR <ILLEGAL DATA TYPE COMBINATION FOR KILL SET>
EN.W1: TLNE TBITS,SBSCRP ;IF STRING ARRAYS, TURN
TRZ TBITS,STRING ;OFF THE STRING PART.
TRNE TBITS,ITEM!ITMVAR ;IGNORE DATUM TYPE OF ITEMS
;;%BI% ALSO NO WORRY ABOUT PNTVAR
REC <
TRZ TBITS,STRING!BOOLEAN!INTEGR!SET!LSTBIT!FLOTNG!PNTVAR
>;REC
NOREC <
TRZ TBITS,STRING!BOOLEAN!INTEGR!SET!LSTBIT!FLOTNG
>;NOREC
MOVE PNT2,TTOP ;CURRENT BLOCK.
TLNE TBITS,OWN ;IF OWN, THEN DONTSAVE BIT
JRST IORDON ;
SKIPN SIMPSW ;BETTER NOT LET SIMPLE DO ALLOC
JRST .+3 ;HE ISNT SIMPLE
NOREC <
TDNE TBITS,[XWD SBSCRP,SET] ;CHECK FOR BAD GUYS
>;NOREC
REC <
TDNE TBITS,[XWD SBSCRP,SET!PNTVAR] ;CHECK FOR BAD GUYS
>;REC
ERR <SIMPLE PROCEDURES MAY NOT ALLOCATE!>,1,IORDON
IORM TBITS,$VAL(PNT2) ;THE "OR" OF ALL SYMBOLS DEFINED.
IORDON:
GLOC <
TRNN TBITS,ITEM ;IF ITEM OR
TRNN TBITS,GLOBL ;NOT GLOBAL, THEN GO ON
JRST NOGLB
TLNE FF,TOPLEV ;IF NOT AT TOP LEVEL
TRNE TBITS,STRING!LABEL ;OR IF THESE RIDICULUOUS TYPES.
ERR <INVALID GLOBAL TYPE>,1
AOS A,GLOBCNT ;COUNT OF GLOBALS.
CAILE A,GLBAR ;WITHIN BOUNDS OF GLOBAL AREA?
ERR <TOO MUCH GLOBAL DATA>,1
HRLM A,$VAL2(PNT) ;AND SAVE.
NOGLB:
>;GLOC
; FOLLOWING REMOVED TO ALLOW INTRODUCTION OF STRING ITEMS.
; TRNN TBITS,LPARRAY
; JRST [TRNN TBITS,STRING
; JRST .+1
; TRNE TBITS,ITEM!ITMVAR
; ERR <STRING ITEMS NOT IN, ALTHOUGH STRING ARRAY ITEMS ARE>,1
; JRST .+1]
NOGRUMP:
TRNE TBITS,ITEM!ITMVAR!SET ;A LEAP DATA TYPE?
SETOM LEAPIS ;TELL WORLD SOMEONE USED LEAP.
TRNN TBITS,ITEM ;WAS IT AN ITEM?
POPJ P,
PUSH P,PNT ;SAVE ITEM SYMBOL POINTER
PUSH P,BITS
GLOC <
TRNE TBITS,GLOBL ;IF A GLOBAL ITEM, THEN MAKE LEFT HALF
SOSA A,GITEMNO
>;GLOC
;; %AG% LH(ITEMNO) NOW CONTAINS ITEM!START
AOS A,ITEMNO ;MAKE A NEW NUMBER FOR IT
HRRZS A
;; %AG%
AOS ITMCNT ;TOTAL NUMBER OF DECLARED ITEMS
PUSHJ P,CREINT ;MAKE AN INEGER OF ITEM NUMBER.
MOVE PNT2,PNT
PUSH P,A ;SAVE ITEM NUMBER
SKIPN PNMSW ;PNAMES GOING NOW ?
JRST NOPNM ;NO
AOS PNMSW ;INDEX COUNT.
PUSHJ P,STRINS ;MAKE ANOTHER COPY OF NAME
HRL PNT,A ;ITEM NUMBER.
QPUSH (PNLST,PNT) ;SAVE FOR LATER.
NOPNM:
MOVE A,-1(P) ;TYPE BITS
PUSHJ P,ITMTYP ;GET TYPE INDEX
HRL A,(P) ;ALSO ITEM NUMBER
QPUSH (ITMSTK)
POP P,A ;RESTORE A
POP P,BITS
POP P,LPSA
;; #KW# DON'T ALLOW INTERNAL OR EXTERNAL ITEMS
MOVE TBITS,$TBITS(LPSA)
TLZE TBITS,EXTRNL!INTRNL ;ITEMS CAN'T BE INTERNAL OR EXTERNAL
ERR <ITEMS CAN'T BE INTERNAL OR EXTERNAL>,1
MOVEM TBITS,$TBITS(LPSA)
;; #KW#
MOVEM PNT2,$VAL2(LPSA) ;SAVE THE POINTER TO INTEGER!!!!
POPJ P, ;EVEN IF "GOGOL", ITEMS DON'T NEED LOCATIONS
IDLIS: TRNN TBITS,PROCED
TLNE TBITS,SBSCRP
JRST [TLZE TBITS,VALUE
ERR <VALUE PROCEDURE OR ARRAY CALLS NOT IMPLEMENTED>,1
TLO TBITS,REFRNC
TRZ TBITS,INPROG ;ONLY RELEVANT TO PROCED
JRST IDFXN]
TLNN TBITS,REFRNC
TLO TBITS,VALUE ;IMPLIED VALUE
IDFXN: TRNE TBITS,PROCED
TLO TBITS,ANYTYP
MOVEM TBITS,$TBITS(PNT)
;;#HR# 6-14-72 JRL HANDLE STRING ITEMVAR FORMAL PARAMETERS
TRNE TBITS,ITEM!ITMVAR ;IGNORE STRING BIT IF ITEM
TRZ TBITS,STRING
;;#HR#
TRNE TBITS,STRING ;UPDATE THE STACK
TLNE TBITS,REFRNC ;COUNTERS ACCORDING
AOSA APARNO ;TO THE TYPE OF PARAMETER
AOS SPARNO
POPJ P,
↑ENDDEC:PUSHJ P,ENDJMP ;FIX UP JUMP AROUND PROCS, IF ANY
JFCL ;IGNORE SKIPPEDNESS
SKIPN LPSA,GENLEF+1 ;DID WE DEFINE ANYTHING?
POPJ P, ;NO -- RETURN
HRRZ TEMP,PCNT ;UPDATE LOC OF FIRST WORD OF BLOCK
HRLM TEMP,$VAL2(LPSA)
ENDDE: TLZ FF,TOPLEV
POPJ P, ;ALL DONE
↑↑ENDJMP:
MOVE TEMP,TPROC ;SURROUNDING PROCEDURE SEMANTICS
HLRZ TEMP,%TLINK(TEMP) ;2D PROC BLOCK
SKIPN B,$SBITS(TEMP) ;DID ANYBODY JUMP? (SEE PRDEC)
JRST CPOPJ1 ; NOBODY DID
SETZM $SBITS(TEMP) ;CLEAR FOR NEXT TIME
HRL B,PCNT
JRST FBOSWP ;NOW FIX UP JUMP AND QUIT
↑CPOPJ1:AOS (P) ;THE CANONICAL SKIP-RETURN
POPJ P, ;DONE
;HERE WHEN YOU SEE THE MATCHING "END"
↑UP1: SKIPA PNT,GENLEF+1 ;FOR CODE!BEGIN SEQUENCES
↑UP2: MOVE PNT,GENLEF+2 ;BEGIN SEMANTICS.
UPPP: MOVEM PNT,GENRIG ;SAVE FOR NAME CHECKING.
JUMPE PNT,NMSUB ;NO BLOCK ASSOCIATED WITH THIS BEGIN
BAIL<
MOVE TEMP,PCNT
HLRZ LPSA,%TLINK(PNT) ;LPSA=SECOND BLOCK SEMBLK
SKIPE LPSA ;IS IT THERE?
HRLM TEMP,$VAL2(LPSA) ;YES, STORE LAST WORD OF CODE
>;BAIL
JUMPL PNT,UPCHK ;THIS BLOCK HAS DECLARATIONS ...
;;#%%# BY JFR 11-8-74 FIX WHAT I DID YESTERDAY
BAIL<
SKIPE BAILON
JRST .+3 ;YES. PRETEND IT HAS A NAME--WILL BE SUPPLIED BY BAISYM
>;BAIL
;;#%%# ↑
SKIPN $PNAME(PNT) ;NAMED COMPOUND STATEMENT?
JRST NONM ; NO, FORGET IT
HRRZS PNT ;LH 0 TO INDICATE PRESENCE OF NAME
QPUSH (BLKIDX,PNT) ;PUT CPD STMT SEMBLK IN STACK
SETZM %RVARB(PNT) ;MAKE SURE THERE'S NO LIST
SOS NMLVL ;LOWER DDT LEVEL BY ONE
CREFWQ:
TLNN FF,CREFSW ;CREFFING ?
POPJ P, ;DON'T DELETE THE BLOCK
MOVEI LPSA,(PNT) ; POINTER TO BLOCK.
JRST CREFBLOCK ;AND CREF BLOCK EXIT.
NONM: MOVE LPSA,PNT
PUSHJ P,URGSTR ;IN CASE IT WAS A NAMED BLOCK..!!
FREBLK <PNT>
NMSUB: POPJ P,
UPCHK: PUSHJ P,GOSTO ;STORE EVERYONE
MOVE TBITS,$VAL(PNT)
;;#KT# ! TYPO AS TO WHERE KILL SET IS
HRRZ C,$ACNO(PNT) ;IF WE HAVE A KILL LIST
JUMPN C,DBEX ;MUST BEXIT
LDB C,[POINT LLFLDL,$SBITS(PNT),35] ;PICK UP LEXIC LEVEL
CAIE C,1 ; IF NOT GLOBAL AND
NOREC <
TDNN TBITS,[ XWD SBSCRP,SET] ;IF ONE OF THE BAD GUYS
>;NOREC
REC <
TDNN TBITS,[ XWD SBSCRP,SET!PNTVAR] ;IF ONE OF THE BAD GUYS
>;REC
JRST EMJR ;THINGS ARENT SO EASY
;;#KX# 1-9-73 DO ALLSTO BEFORE YOU BEXIT -- RHT
DBEX: PUSHJ P,ALLSTO ;
HRR C,PCNT
HLL C,$SBITS(PNT)
HRLM C,$SBITS(PNT) ;FIXUP BK LVI REF
EMIT <MOVEI LPSA,NOUSAC!USADDR>
XCALL <BEXIT>
EMJR: HRROS PNT ;ASSUME NO NAME
SKIPE $PNAME(PNT)
JRST [HRRZS PNT ;WRONG AGAIN
SOS NMLVL ;NAME LEVEL
PUSHJ P,CREFWQ ;POSSIBLY CREF BLOCK EXIT.
JRST .+1]
HLRZ A,$TBITS(PNT) ;BITS OF PROTECTED ACS
COMMENT ⊗ HORRIBLE LOOP TO UNDO PROTECTION OF ACS IN THIS BLOCK ⊗
PUSH P,B
PUSH P,D
MOVEI D,11
;;#RN# USED TO BE 1000
;; MOVEI B,2000 ;BIT FOR AC 11
;;#RW# SHOULD BE 1000, AFTER ALL (IE 1 LSH 9 = '1000)
MOVEI B,1000
UPACHK: TDZE A,B ;DID WE PROTECT IT
HRRZS ACKTAB(D) ;UNPROTECT IT
LSH B,-1
SOJGE D,UPACHK ;
POP P,D
POP P,B
;**************************************
REC <
RCLPOP: QPOP(RCLPDL) ;GET A RECORD CLASS BLOCK
JUMPE A,[
ERR <DRYROT AT RCLPOP>,1
JRST RPPPD
]
CAMN A,[-1] ;THIS WAS THE SIGN
JRST RPPPD ;ALL DONE
HRRZ LPSA,A ;A SEMBLK
FREBLK ;RETURN IT
JRST RCLPOP ;& ASK FOR ANOTHER ONE
RPPPD:
>;REC
QPUSH(BLKIDX,PNT)
MOVE A,$ADR(PNT)
HLRM A,TTOP ;RESTORE IT.
HRRM A,VARB ;RESTORE THE VARB POINTER.
SOS LEVEL
JRST FREBUK ;come up a level in symbol buckets.
; Check for match on block names.
↑NAMCHK: SKIPN PNT,GENLEF+1 ;BLOCK SEMANTICS.
JRST NMCHKK
MOVE PNT2,GENLEF ;END NAMED.
MOVE A,$PNAME+1(PNT) ;BYTE POINTER.
JUMPE A,NMCHKK ;BLOCK UNNAMED
CAMN A,$PNAME+1(PNT2) ;AND THE OTHER
POPJ P,
JRST MTCERR ;NO GOOD
NMCHKK: MOVE TEMP,TPROC ;TRY FOR MATCH WITH
MOVE PNT2,GENLEF ;END NAMED
MOVE A,@$PNAME+1(TEMP) ;CURRENT PROC NAME
CAMN A,@$PNAME+1(PNT2) ; (FIRST WORD MATCH ONLY)
POPJ P,
SKIPN PNT
ERR <NAME AFTER UNNAMED BLOCK!>,1,CPOPJ
MTCERR: ERR <NAMES OF BEGIN AND END DO NOT MATCH>,1
POPJ P,
SUBTTL EXECS for REQUIRE Verb
DSCR RQ00, RQSET, SRCSWT
PRO RQ00 RQSET SRCSWT REQERR
DES These routines handle the REQUIRE Syntax of the forms:
| | PNAMES
| | SYSTEM!PDL
| | STRING!PDL
| n | STRING!SPACE
| | ARRAY!PDL
| | NEW!ITEMS
| | VERSION
REQUIRE |-----------------------|
| | LIBRARY
| | LOAD!MODULE
| "file description" | SEGMENT!FILE
| | SEGMENT!NAME
| | SOURCE!FILE
|-----------------------|
| "2 or 4 characters" | DELIMITERS
|-----------------------|
| "some characters" | ERROR!MODES
PNAMES and SOURCE!FILE are handled specially
⊗
;; %AN% - ALL REQUIRE STUFF MODIFIED TO ALLOW CONSTANT EXPRESSIONS,
;; THIS CODE USED TO LOAD AC A FROM SCNVAL, AND THE INDIVIDUAL ROUTINES
;; DID WHAT THEY WISHED WITH IT.
↑DEFZRO: ;DEFAULT OF ZERO IF NO CONSTANT EXPRESSION
MOVEI A,0
PUSHJ P,CREINT
MOVEM PNT,GENLEF+1
POPJ P,
↑RQSET:
SETZM BITS ;IN CASE UNARY WAS CALLED
GETSEM (1) ;SEMANTICS OF CONSTANT
XCT RQTAB(B) ;DO SOMETHING
ZPOPJ: POPJ P,
RECORD:
TRNN TBITS,INTEGR ;BETTER BE INTEGER CONSTANT
ERR <THIS REQUIRE NEEDS INTEGER EXPRESSION>,1
MOVE A,$VAL(PNT) ;THE INTEGER VALUE
;;#TR# FIX THIS CODE
; HRRZ TEMP,SPCTBL ;THE SPACE RESERVATIN TABLE
; ADDI TEMP,1 ;ONE MORE WORD
; HRRM TEMP,SPCTBL ;HOPEFULLY
;;%BR%
IFN 0,<
HACK <
CAIN TEMP,=18 ;OVERFLOW?
ERR <TOO MANY SPACE REQUIRES>,1
CAILE TEMP,=17 ;PREVIOUS OVERFLOW?
POPJ P, ;YES
HRL A,B ;THE INDEX INDICATES WHICH
TLO A,STDSPC ; SPACE IS REQUESTED
MOVEM A,SPCTBL+1(TEMP) ;INTO LOADER BLOCK FOR LATER OUTPUT
POPJ P,
>;HACK
>;0
;; OLD NOHACK HERE
; CAILE TEMP,=18
; ADDI TEMP,1 ;FOR RELOC WORD
; CAIL TEMP,=35 ;TOO MANY??
; ERR <TOO MANY SPACE REQUIRES>,1,CPOPJ
; HRL A,B ;THE INDEX TO SAY WHICH
; TLO A,STDSPC ;THE OP CODE
; MOVEM A,SPCTBL+1(TEMP)
;ZNXSRE: SETZM SPCTBL+2(TEMP)
; CAIE TEMP,=18
; POPJ P,
; AOS SPCTBL
; AOJA TEMP,ZNXSRE ;GO MAKE A ZERO
;;OLD NOHACK ↑
;;%BR% ↑
AOS TEMP,SPCTBL ;BUMP WORD COUNT
HRRZ TEMP,TEMP ;WORD CNT IS IN RHS
CAILE TEMP,=18 ;NEED EXTRA OFFSET FOR RELOC BYTE?
ADDI TEMP,1 ;YES
CAIL TEMP,=35 ;TOO MANY??
JRST [ERR <TOO MANY SPACE REQUIRES>,1
SOS SPCTBL
POPJ P, ]
HRL A,B ;THE INDEX TO SAY WHICH
TLO A,STDSPC ;THE OP CODE
MOVEM A,SPCTBL+1(TEMP)
SETZM SPCTBL+2(TEMP) ;MAKE A ZERO FOR THE NEXT ONE
CAIN TEMP,=18 ;IS THIS THE END OF FIRST GROUP?
SETZM SPCTBL+3(TEMP) ;YES, ALSO HAVE A RELOC WORD TO ZERO
POPJ P,
;;#TR# ↑
RQTAB:
JRST PNAM ;PNAMES
JRST RECORD ;SYSTEM PDL
JRST RECORD ;STRING PDL
JRST RECORD ;STRING SPACE
JFCL ;ARRAY PDL NO LONGER EXISTS
JRST RNWITM ;NEW ITEMS
JRST RVERNUM ;VERSION NUMBER
JRST LBSET ;LIBRARY REQUEST
JRST PRGSET ;LOAD MODULE REQUEST.
JRST REQERR ;SOMETHING WRONG WITH SOURCE!FILE RQST
JRST DELSTG ; PROCESS REQUIRE DELIMITERS COMMAND
JRST REPDEL ; PROCESS REPPLACE DELIMITERS COMMAND
JRST POPDEL ; PROCESS POP!DELIMITERS COMMAND
JRST NULDEL ; PROCESS NULL!DELIMITERS COMMAND
SETOM ALLGLO ; COMPILE FOR GLOBAL LEAP ONLY
JRST SEGSET ;LOGICAL SEGMENT NAME REQUEST
JRST SEGFL ;SEGMENT FILE NAME REQUEST
JRST INMAIN ;GO INITIALIZE MAINPR
JRST REQPLL ; POLLING INTERVAL
JRST LPBUCK ; REQUIRE n BUCKETS
JRST ITMSTRT ;ITEM START
JRST MODSET ;ERROR MODES
RNWITM:
TRNN TBITS,INTEGR ;INTEGER REQUIRED
ERR <THIS REQUIRE NEEDS INTEGER CONSTANT>,1
MOVE A,$VAL(PNT)
HRRM A,NWITM ;INTO SPACE ALLOCATION BLOCK
POPJ P,
RVERNUM:
TRNN TBITS,INTEGR!FLOTNG
ERR <THIS REQUIRE NEEDS ARITHMETIC CONSTANT>,1
MOVE A,$VAL(PNT)
MOVEM A,VERNO
POPJ P,
LBSET: SKIPA B,[LBTAB] ;LIBRARY OUTPUT BLOCK ADDR
PRGSET: MOVEI B,PRGTAB ;PROGRAM OUTPUT BLOCK ADDR
TRNN TBITS,STRING ;HAD BETTER BE STRING CONSTANT
ERR <THIS REQUIRE NEEDS STRING CONSTANT>,1,ZPOPJ
HRROI TEMP,$PNAME+1(PNT)
POP TEMP,PNAME+1
POP TEMP,PNAME ;SET UP FOR CALL
JRST PRGOUT ;OUTPUT REQUEST, RETURN
SEGSET:
GLOC <
PUSHJ P,GETSOM ;GET NAME, SET UP TABLE POINTER
MOVEM C,SEGNAM ;NAME ONLY, PUT IN SPACE BLOCK
>;GLOC
POPJ P,
SEGFL:
GLOC <
PUSHJ P,GETSOM
JUMPN A,.+2 ;DEVICE
MOVSI A,(<SIXBIT /DSK/>) ;DEFAULT
MOVEM A,SEGDEV ;DEVICE NAME
MOVEM C,SEGFIL ;FILE NAME
MOVEM D,SEGPPN ;WHEEE (TRANSLATION -- PPN)
>;GLOC
POPJ P,
GLOC <
GETSOM: ;PNT pnts to STRING REPRESENTING REQUEST
TRNN TBITS,STRING ;HAD BETTER BE STRING CONSTANT
ERR <THIS REQUIRE NEEDS STRING CONSTANT>,1,ZPOPJ
HRROI TEMP,$PNAME+1(PNT) ;PNAME
POP TEMP,PNAME+1
POP TEMP,PNAME
JRST FILSCN ;CONVERT TO SIXBIT IN A,C,D
>;GLOC
DELSTG: ; SEMANTICS OF STRCON ALREADY SET UP
TLNE TBITS,CNST ; CONSTANT?
TRNN TBITS,STRING ; STRING?
ERR <NOT A STRING CONSTANT - STATEMENT IGNORED>,1,CPOPJ ;
↑GETDEL: HRRZ LPSA,$PNAME(PNT) ; GET STRING CHARACTER COUNT
JUMPE LPSA,NULDEL ; NULL DELIMITER STRING?
MOVE PNT,$PNAME+1(PNT)
QPUSH (DELSTK,<(PNT)>) ; SAVE THE DELIMITERS
GETDL1: SETOM REQDLM
MOVE TEMP,[XWD -DELNUM,0] ; FOR AOBJN
↑GETDL2:SOJGE LPSA,.+2 ; DELIMITER SCANNER LOOP
ERR <NOT ENOUGH DELIMITERS IN INPUT - GARBAGE IN REST> ;
ILDB B,PNT ; GET NEXT DELIMITER
SKIPG SCNTBL(B) ; SPECIAL OR IGNORABLE?
JRST GETDL2 ; YES, GET NEXT
SKIPN SWBODY ; SPECIAL DELIMITER DEFINITION?
MOVEM B,LOCMBD(TEMP) ; NO, STORE FOR PERMANENT REFERENCE
MOVEM B,CURMBG(TEMP) ; STORE FOR TEMPORARY REFERENCE
AOBJN TEMP,GETDL2 ; CHECK IF DONE
POPJ P, ; YES
REPDEL: QPOP (DELSTK)
JRST DELSTG
POPDEL: QPOP (DELSTK)
QLOOK(DELSTK) ; GET A POINTER TO TOP ELEMENT OF DELSTK
SETZM REQDLM
SKIPN (A)
POPJ P,
HRLI A,(<POINT 7,0>)
MOVE PNT,A
MOVEI LPSA,DELNUM
JRST GETDL1
NULDEL: SETZM REQDLM
QPUSH (DELSTK,REQDLM)
POPJ P,
↑MKNSTB: MOVEI C,1 ; INITIALIZE COUNT FOR NESTABLE CHARS.
MOVEI A,NUMCHA ; NUMBER OF CHARACTERS
CONCNV: SOJL A,CPOPJ ; DONE?
MOVE B,SCNTBL(A) ; LOAD AND TEST IF NESTABLE CHARACTER
TLNN B,NEST ;
JRST CONCNV ; NO, GET NEXT CHAR
MOVEM C,NSTABL(A) ; YES, NSTABL CONTAINS INDEX AMOUNT
; TO BE ADDED TO LOCNST
TLNE B,LNEST ; DONE WITH A NESTED PAIR?
ADDI C,1 ; YES, INCREMENT COUNTER
JRST CONCNV ; GET NEXT
COMMENT ⊗REQPLL -- SETS POLINT⊗
↑REQPLL:
TLNE TBITS,CNST ;BETTER BE CONSTANT INTEGER
TRNN TBITS,INTEGR ;
ERR <INVALID SPEC TO REQUIRE>,1,CPOPJ
MOVE A,$VAL(PNT) ;GET VALUE
MOVEM A,POLINT ;
JUMPG A,INMAIN
POPJ P,
LPBUCK: ; FOR REQUIRE n BUCKETS
TRNN TBITS,INTEGR ; BETTER BE INTEGER
ERR <THIS REQUIRE NEEDS INTEGER CONSTANT>,1,CPOPJ
JUMPGE A,.+2
MOVEI A,0 ; MAKE SURE IS POSITIVE
JFFO A,.+2 ; FIND FIRST ONE
JRST MINBKT ; MINIMUM NUMBER OF BUCKETS IS 2
HRLZI C,400000 ; A BIT FOR TESTING
MOVN B,B
LSH C,(B) ; C NOW IS THE LARGEST POWER OF TWO
; SUCH THAT C LEQ n
CAME A,C ; SEE IF n WAS A POWER OF TWO
LSH C,1 ; NO, GO TO NEXT HIGHER POWER.
HAVSIZ: HRLM C,NWITM
POPJ P,
MINBKT: MOVEI C,2
JRST HAVSIZ
;; %AG% ITEM!START
↑↑ITMSTRT:
MOVE TEMP,[XWD 11,10] ;SEE IF LEGAL
CAME TEMP,ITEMNO
ERR <ITEM!START REQUIRED TWICE OR AFTER ITEM DECLARATION>,1
TRNN TBITS,INTEGR ;INTEGER REQUIRED
ERR <THIS REQUIRE NEEDS INTEGER CONSTANT>,1
CAILE A,10
CAIL A,7777
ERR <INVALID ARGUMENT TO REQUIRE ITEM!START>,1
HRLI A,(A)
SUBI A,1 ;SO FIRST WILL ALLOCATE
MOVEM A,ITEMNO
POPJ P,
;; %AG%
MODSET:
AOS %QUIET ;MAKE EVERY THING QUIET
MOVEI B,[0]
MOVEM B,..STR ;NULL MESSAGE
SETZM ..LOCA
AOS ..LOCA ;LOCATION IS 0
TRNN TBITS,STRING
ERR <THIS REQUIRE NEEDS STRING CONSTANT>,1
SKIPN B,$PNAME(PNT) ;STRING LENGTH
POPJ P,
HRRZ B,B
PUSH P,B ;SAVE SO DSPATC DOESN'T KILL
MOVE PNT,$PNAME+1(PNT) ;THE STRING
PUSH P,PNT ;SAVE! SAVE! SAVE! REGISTER PARANOIA
REP..: SOSL -1(P) ;DECREMENT CHARACTER COUNT
JRST UNNCDE ;DECODE CHAR
SOSGE %QUIET ;RAN OUT OF STRING SO GO AWAY
SETZM %QUIET ; IN CASE ANY SETZM %QUIETS IN DSPATCH
SUB P,X22 ;FIX STACK
POPJ P,
UNNCDE: ILDB B,(P) ;FIRST LETTER
PUSHJ P,DSPATC ;GO PRETEND THIS IS A REALLY ERROR
CAIE B,"A" ;RETURNS HERE IF LETTER IS ACTIVATION LETTER
JRST REP.. ;RETURNS HERE IF LETTER IS MODE OR UNKNOWN
SETOM %ERGO
JRST REP..
EXTERNAL OUTSTR
↑TYPMSG:
MOVE USER,GOGTAB;
MOVE SP,SPDL(USER)
GETSEM (1)
TRNN TBITS,STRING
ERR <THIS REQUIRE NEEDS STRING CONSTANT>,1,CPOPJ
PUSH SP,$PNAME(PNT)
PUSH SP,$PNAME+1(PNT)
PUSHJ P,OUTSTR ;WRITE IT OUT
JRST SCOMM1 ;ZAP STC BLOCK
↑SRCSWT:
; FIRST CHECK VALIDITY OF SOURCE!FILE SWITCHING RQST, SET SPECIAL SWITCHER
MOVE TBITS2,SCNWRD
TLNE TBITS2,MACIN ;IF IN MACRO, ILLEGAL
ERR <DON'T SWITCH SOURCE FILES INSIDE MACRO>,1,SCANNER
SETOM SRCDLY ;FLAG SCANNER
POPJ P,
; NOW TRY THE SWITCH-OVER
; CHECK IF THE FILE WAS ACTUALLY SWITCHED
↑SRCCHK: SKIPE SRCDLY ;WILL BE ZERO IF SWITCHED
ERR <SOURCE FILE REQUEST MUST END LINE>
POPJ P,
↑REQERR: ERR <INVALID SYNTAX -- SOURCE FILE REQUEST>,1
POPJ P,
SUBTTL EXECS for MACRO (DEFINE) Declarations
DSCR DFPREP, DCPREP, DWPREP, DFPINS, DFSET, DFENT, MACOFF, MACON
PRO DFPREP DCPREP, DWPREP, DFPINS DFSET DFENT MACOFF, MACON
DES Execs for syntax
DEFINE macnam(a1,a2..)="macro body", macnam2=....,...;
Relies heavily on mechanisms built into the SCANNER to
parse the macro body, insert parameters.
SEE SCANNER
⊗
Comment *
DFR: @I ( drarrow DPL EXEC DFPR1 SCAN 2 GO TO DPA
@I SG drarrow DPL SG EXEC DFPREP GO TO LEQ OR GO TO Q0
DFPREP -- prepare to define a macro body.
Enter DEFINE symbol. Use current def if
it's at the same level (done in ENTER). Get
a new symbol table bucket.
DCPREP -- prepare to define a conditional compilation CASEC body.
Check if first casec and if not then enter the computed
casec value in the $VAL2 entry of the semblk obtained for
the casec body.
DWPREP -- prepare to define a conditional compilation WHILEC, FORC,
or FORLC body. *
↑MACON: TLZ FF,NOMACR ; TURN MACRO EXPANSION ON
POPJ P, ; RETURN
↑EVMCOF: SKIPN EVLDEF ; TURN OFF MACRO EXPANSION ONLY IF
; EVALDEFINE IS NOT IN PROGRESS
↑MACOFF: TLO FF,NOMACR ;NO MACRO EXPANSIONS WHEN REDEFINING!
POPJ P,
↑DCPREP: GETBLK NEWSYM ; SEMBLK FOR CASEC BODY
GETSEM (1) ; SEMANTICS OF CASEC NUMBER
MOVE TEMP,$VAL(PNT) ; GET CASEC NUMBER
JUMPN TEMP,NOFRST ; TWIDDLE IF NOT FIRST CASEC
PUSHJ P,CPSHEN ; SET ENDC DOESN'T TRIGGER A PARSER SWITCH FLAG
SETOM SWCPRS ; PARSER SWITCHING IS OK (I.E. IFC IN BODY OF CASEC
; TO BE EXECUTED)
JRST CMPRP2 ; DON'T TWIDDLE SINCE FIRST CASEC
NOFRST: MOVEM TEMP,$VAL2(LPSA) ; STORE CASEC NUMBER IN $VAL2 OF THE SEMBLK
MOVEM LPSA,GENRIG+1 ; SAVE SEMANTICS OF PSEUDO MACRO BODY SEMBLK
MOVE TEMP,%CFLS1 ; TWIDDLE
MOVEM TEMP,PARRIG ; NOT THE FIRST CASEC
JRST DWPRP1 ; REST OF MACRO BODY PRELIMINARIES
↑DWPREP: GETBLK NEWSYM ; SEMBLK FOR WHILEC, FORC, OR FORLC BODY
DWPRP1: HRLZI TEMP,DEFINE ; GET GOOD BITS
MOVEM TEMP,$TBITS(LPSA) ; SET SEMBLK DESCRIPTOR
HRRZS %TLINK(LPSA) ; ZERO THE MACRO BODY DEFINITION LINK
JRST CMPRP2 ; REST OF MACRO BODY PRELIMINARIES
↑DFPREP: HRLZI TEMP,DEFINE ; GET GOOD BITS
MOVEM TEMP,BITS ; PREPARE TO DO AN ENTERS
PUSHJ P,ENTERS ; ENTER MACRO NAME IF NOT ALREADY DEFINED
MOVE LPSA,VARB ; CHECK IF DEFINE IS HAPPENING BEFORE THE
SKIPN LEVEL ; OUTER LEVEL BLOCK HAS BEEN STARTED. IF
MOVEI LPSA,RESYM ; YES, THEN SET VARB TO RESYM SO DONES WILL
MOVEM LPSA,VARB ; WORK PROPERLY.
CMPRP2: PUSHJ P,MAKBUK ;DOWN ONE LEVEL FOR PARAMETERS
AOS LEVEL
MOVE LPSA,NEWSYM ;SYMANTICS OF ENTRY
MOVEM LPSA,GENRIG ;MAY BE GARBAGING "="'S SEMANTICS
MOVE TEMP,VARB ;SAVE VARB LIST -- WILL LINK FORMALS
MOVEM TEMP,$ADR(LPSA) ; OLD VARB POINTER IS SAVED IN $ADR SO THAT
; THE MACRO BODY IS STILL KNOWN
SETZM VARB
HLLZS $VAL(LPSA) ;CLEAR #PARAMS COUNT (SAVE COUNT FOR PREV DEF).
SETZM $ACNO(LPSA) ;WILL POINT AT FIRST PARAM
TLZ FF,NOMACR ;MACROS EXPANDED AGAIN
POPJ P,
Comment ⊗
DPA: SG @I , drarrow SG EXEC DFPINS SCAN 2 ¬DPA
SG @I ) drarrow SG EXEC DFPINS SCAN ¬LEQ #Q0
Insert macro parameter:
1. Enter the symbol
2. Insert in list off %TLINK in macro name semantics ⊗
↑MDFPNS: TLZ FF,NOMACR ; MACROS EXPANDED AGAIN WHEN THROUGH SCANNING
; FORMALS
↑DFPINS: HRLZI TEMP,FORMAL!DEFINE ;ENTER PARAM (LINK ON SPECIAL VARB RING)
MOVEM TEMP,BITS
PUSHJ P,ENTERS
MOVE TEMP,GENLEF+2 ;SEMANTICS FOR MACRO NAME
AOS A,$VAL(TEMP) ;COUNT MACRO PARAMS
MOVE LPSA,NEWSYM ;SEMANTICS OF THIS PARAM
SKIPN $ACNO(TEMP) ;IS THIS THE FIRST ONE?
MOVEM LPSA,$ACNO(TEMP) ; YES, STORE POINTER TO FIRST
HRRZM A,$VAL(LPSA) ;STORE PARAM NUMBER
POPJ P,
Comment ⊗
LEQ: STC drarrow EXEC SPDMBD SCAN ¬LEQ1
Check if a special macro body delimiter declaration has occurred ⊗
↑SPDMBD: SKIPN REQDLM ; TRYING TO OVERRIDE NULL DELIMITER MODE?
SETOM RSTDLM ; YES, SET FLAGS SO CAN RESET PROPERLY WHEN DONE
SETOM REQDLM ;
SETOM SWBODY ; SET SWITCH DELIMITER DECLARATION FLAG
MOVE TEMP,[XWD -2,0] ; SET UP A COUNT
MOVE PNT,GENLEF ; GET SEMBLK ADDRESS OF STRING
HRRZ LPSA,$PNAME(PNT) ; GET READY FOR A SPECIAL DELIMITER MODE
MOVE PNT,$PNAME+1(PNT) ; SCAN
JRST GETDL2 ; GET SPECIAL DELIMITERS
Comment ⊗
LEQ1: = drarrow EXEC DFSET SCAN 2 ¬DEQ #Q0
Get ready for macro body ⊗
↑DFSET: JRST FFPUSH ; SAVE DEFLUK BIT OF FF AND TURN IT ON IN FF
Comment ⊗
DEQ: DPL ICN , drarrow EXEC DFINE SCAN 2 ¬DFR
DDEF DPL ICN ; drarrow EXEC DFINE SCAN ¬DS0
SDEF DPL ICN ; drarrow EXEC DFINE SCAN ¬S1 #Q0
Eradicate formal parameter ring, turn off special
string mode bit after macro scan -- install the macro body. ⊗
↑DFENT1: MOVE A,GENLEF+3 ; SEMBLK OF CASEC ENTRY
JRST NOREDF ; NO PARAMETER LIST TO DELETE
↑DFENT: MOVE A,GENLEF+2 ; GET SEMBLK ADDRESS
MOVE LPSA,$ACNO(A) ; FORMAL LIST
PUSHJ P,KILLST ; DELETE FORMAL PARAM LIST
SETZM $ACNO(A) ; NO MORE LIST
HRRZ TEMP,$VAL(A) ; #PARAMS FOR THIS (NEW) DEFINITION
HRLZM TEMP,$VAL(A) ; #PARAMS FOR CURRENTLY ACTIVE DEF.
HLRZ LPSA,%TLINK(A) ; CHECK IF THE MACRO HAS BEEN PREVIOUSLY
JUMPE LPSA,NOREDF ; DEFINED, AND IF YES DELETE THE PREVIOUS
PUSHJ P,REMOPL ; DEFINITION IF IT IS THE ONLY REFERENCE TO IT
NOREDF: MOVE TEMP,$ADR(A) ; RESTORE SAVED VARB POINTER
MOVEM TEMP,VARB ; (IT WAS USED TO KEEP FORMALS LOCATED)
MOVE LPSA,GENLEF+1 ; MACRO BODY (STRING CONST) SEMANTICS
MOVE TBITS,$TBITS(LPSA) ; GET GOOD BITS
TRNE TBITS,STRING ; TEST IF A STRING AND SET IT TO STRING
JRST NOCNST ; YES, NO NEED TO CONVERT CONSTANT TO STRING
PUSH P,$VAL(LPSA) ; PUSH VALUE
PUSHJ P,REMOPL ; DELETE SEMBLK OF NUMERIC CONSTANT IF POSSIBLE
EXCH SP,STPSAV ; GET STRING POINTER
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
PUSHJ P,CVS ; CONVERT TO STRING
POP SP,PNAME+1 ; FIRST WORD OF STRING DESCRIPTOR
POP SP,PNAME ; SECOND WORD OF STRING DESCRIPTOR
EXCH SP,STPSAV ; RETURN STRING POINTER
MOVSS POVTAB+6 ; KEEP ERROR MESSAGES IN SYNCH
PUSHJ P,STRINS ; MAKE STRING CONSTANT
MOVEM PNT,GENLEF+1 ; RECORD RESULTS WHERE WILL BE SEEN
NOCNST: SOS LEVEL
PUSHJ P,FREBUK ;RETURN UP
JRST CLRSET ;CLEAR BITS
↑SWDLM: SKIPN SWBODY ; NEED TO SWAP MACRO BODY DELIMITERS?
POPJ P, ; NO, RETURN
SETZM SWBODY ; RESET SWITCH DELIMITER DECLARATION FLAG
SKIPN RSTDLM ; RESTORING NULL DELIMITERS MODE?
JRST .+4 ; NO
SETZM RSTDLM ; RESTORE THE APPROPRIATE FLAGS
SETZM REQDLM ;
POPJ P, ;
HRROI TEMP,LOCMBD+1 ; GET RESTORING ADDRESS
POP TEMP,CURMED ; RESTORE START DELIMITER
POP TEMP,CURMBG ; RESTORE END DELIMITER
POPJ P, ; RETURN
↑SETDLM: QPUSH(LOKDLM,DLMSTG) ; SAVE CURRENT DLMSTG VALUE
SKIPE REQDLM ; SPECIAL DELIMITER MODE?
SETOM DLMSTG ; YES, POSSIBLY LOOKING FOR DELIMITED STRING
POPJ P, ; RETURN
↑OFFDLM: QPOP(LOKDLM,DLMSTG) ; CEASE LOOKING FOR DELIMITED STRING
POPJ P, ; RETURN
↑ENDMAC:
MOVE LPSA,GENLEF+1 ; GET MACRO BODY SEMBLK
EXCH SP,STPSAV ; GET STRING STACK POINTER
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
PUSH SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR
PUSH SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS
; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
PUSH SP,[XWD 0,2] ; LENGTH OF FOLLOWING STRING
PUSH SP,[POINT 7,[BYTE (7) 177 0]] ; END OF MACRO STRING
PUSHJ P,CAT ; CONCATENATE
POP SP,PNAME+1 ; SECOND WORD OF STRING DESCRIPTOR
POP SP,PNAME ; FIRST WORD OF STRING DESCRIPTOR
PUSHJ P,STRINS ; ENTER MACRO BODY STRING IN SYMBOL TABLE
MOVE LPSA,GENLEF+2 ; LINK MACRO NAME TO MACRO BODY
HRLM PNT,%TLINK(LPSA) ;
EXCH SP,STPSAV ; RETURN STRING POINTER
MOVSS POVTAB+6 ; KEEP ERROR MESSAGES IN SYNCH
POPJ P, ; RETURN
↑SWPON: SETOM SWCPRS ; SWITCHING PARSERS IS ALLOWED
POPJ P, ; RETURN
DSCR STCAT
PRO STCAT
DES Converts a macro body to a string.
CVMS(macname). If called with a macro name and a parameter list, then
the parameters are ignored and a suitable error message is emitted.
⊗
↑STCAT: TLZ FF,NOMACR ; TURN MACRO EXPANSION BACK ON
;;#OS# 10-31-73 HJS CHECK FOR UNDECLARED MACRO NAME
SKIPE LPSA,GENLEF ; IS THIS A DECLARED MACRO?
JRST CVMSOK ; YES,
ERR <NOT A MACRO NAME SUPPLIED TO CVMS> ; NO, RETURN A NULL STRING
SETZM PNAME ;
SETZM PNAME+1 ;
JRST UNDCVM ;
CVMSOK: HLRZ LPSA,%TLINK(LPSA) ; CONVERT TO STRING AND ENTER IT IN THE
; SYMBOL TABLE IF NOT ALREADY THERE.
RM1770:
;; #TA# (1 OF 2) DETECT WHEN LENGTH GOES NEGATIVE
HRRZ TEMP,$PNAME(LPSA) ;
SUBI TEMP,2 ; THE ONLY DIFFERENCE BETWEEN THE
JUMPGE TEMP,.+2
ERR <DRYROT- RM1770>,1
HRRM TEMP,PNAME ; STRING AND THE MACRO BODY IS
;; #TA#
MOVE TEMP,$PNAME+1(LPSA) ; THAT THE STRING DOES NOT HAVE
MOVEM TEMP,PNAME+1 ; 177-0 AT ITS END.
UNDCVM: PUSH P,BITS ;
PUSHJ P,STRINS ;
POP P,BITS ;
MOVEM PNT,GENRIG ; SET THE SEMANTIC STACK ENTRY TO
; THE SEMBLK ADDRESS OF THE STRING.
POPJ P, ;
DSCR CVPFRM, ASGOFF
PRO CVPFRM, ASGOFF
DES These routines are used to implement the CVPS construct which converts a macro
actual parameter to a string.
CVPS(formal parameter name).
CVPFRM This routine fetches the appropriate parameter from the VARB ring associated
with the cureent invocation of the macro and strips off the 177-0 at its end
and converts it to a string.
ASGOFF This routine turns off the flag which inhibits the expansion of macro actual
parameters in case an error has occurred.
⊗
↑CVPFRM: SETZM ASGFLG ; TURN OFF ACTUAL MACRO PARAMETER EXPANSION
MOVE B,GENLEF ; INHIBITION FLAG AND GET SEMBLK OF ACTUAL
MOVE LPSA,DEFRNG ; PARAMETER TO BE CONVERTED TO A STRING
GETITP: SOJE B,RM1770 ;
RIGHT ,%RVARB, ;
JRST GETITP ;
↑ASGOFF: SETZM ASGFLG ; TURN OFF ACTUAL MACRO PARAMETER EXPANSION
POPJ P, ; INHIBITION FLAG
DSCR SPRZER, XOWST1, VALST1, HELAR3, HELST1, TYPST1, RSTST1, MKINT
PRO SPRZER, XOWST1, VALST1, HELAR3, HELST1, TYPST1, RSTST1, MKINT
DES These routines are used to process the CHECK!TYPE command which takes as an
argument a declaration and forms a word containing the apporopriate bits in
SPRBTS.
SPRZER Zeroes SPRBTS.
XOWST1 Gets bits corresponding to @XO.
VALST1 Gets bits corresponding to @VAL.
HELAR3 Gets the LPARRAY bit.
HELST1 Gets the ITEM or ITEMVAR bits.
TYPST1 Gets the @ALGLP bit.
RSTST1 Gets the remaining bits (i.e. PROCED, RES, BILTIN, DEFINE, SBSCRP, and
LPARRAY for a LPARRAY declaration.
MKINT Creates an integer out of the SPRBTS value and places it on the stack.
⊗
↑SPRZER: SETZM SPRBTS ;
SETOM NODFSW ; NO DEFINE TRIGGERING WHILE IN CHECK!TYPE.
POPJ P, ;
↑XOWST1: SKIPA A,XOTAB(B) ;
↑VALST1: MOVE A,VALTAB(B) ;
JRST ENDFRM ;
↑HELAR3: MOVEI A,LPARRAY ;
IORM A,SPRBTS ;
↑HELST1:
↑TYPST1: SKIPA A,TYPTAB(B) ;
↑RSTST1: MOVE A,CHKTAB(B) ;
ENDFRM: IORM A,SPRBTS ;
POPJ P, ;
↑MKINT: SETZM NODFSW ; ALLOW DEFINE TRIGGERING TO HAPPEN AGAIN.
MOVE A,SPRBTS ;
JRST MKINT2 ; MAKE AN INTEGER AND PLACE IT ON THE STACK.
DSCR FFPUSH, FFPOP
PRO FFPUSH, FFPOP
DES These rotines are used to save and restore the DEFLUK bit of FF on a QSTACK
pointed to by DEFDLM. This is necessary due to compile-time variables whose
definition may cause other macros to be called. DEFLUK is used to indicate
that a macro body is about to be scanned or a set of actual parameters to a
macro are about to be scanned.
FFPUSH Saves the DEFLUK bit of FF on a QSTACK pointed to by DEFDLM (actually save
the entire value of FF).
FFPOP Restores the DEFLUK bit of FF from the QSTACK pointed to by DEFDLM.
⊗
↑FFPUSH: MOVEI LPSA,DEFDLM ; GET QSTACK POINTER
MOVE A,FF ; A CONTAINS ITEM TO BE PUSHED IN QSTACK
TLO FF,DEFLUK ; TURN ON DEFLUK BIT IN FF
JRST BPUSH ; PUSH IN QSTACK
↑FFPOP: MOVEI LPSA,DEFDLM ; GET STACK POINTER
PUSHJ P,BPOP ; POP TOP OF QSTACK INTO A
TLZ FF,DEFLUK ; RESTORE DEFLUK BIT OF FF TO PREVIOUS VALUE
TLNE A,DEFLUK ;
TLO FF,DEFLUK ;
POPJ P, ;
DSCR DLMPSH, DLMPOP
PRO DLMPSH, DLMPOP
DES These routines are used to save and restore the DEFLUK bit of FF and the value
of the DLMSTG flag after encountering the DEFINE reserved word and after
encountering the = sign in a macro definition. This is necessary so that macro
names will be properly entered in the symbol table.
DLMPSH Saves the current value of DLMSTG and sets it to zero. Also saves the
current value of the DEFLUK bit of FF and sets it to zero.
DLMPOP Restores the value of DLMSTG from the stack. Also restores the DEFLUK bit
of FF.
⊗
↑DLMPSH: QPUSH(LOKDLM,DLMSTG) ; SAVE DLMSTG
SETZM DLMSTG ; DON'T LOOK FOR DELIMITED STRINGS
MOVEI LPSA,DEFDLM ; GET STACK POINTER
MOVE A,FF ;
TLZ FF,DEFLUK ; STRINGS SCANNED IN NON-MACRO MODE
JRST BPUSH ; PUSH IN QSTACK
↑DLMPOP: QPOP(LOKDLM,DLMSTG) ; RESTORE DLMSTG
JRST FFPOP ; RESTORE DEFLUK
DSCR CPSHBT, CPOPBT, DPSHBT, DPOPBT
PRO CPSHBT, CPOPBT, DPSHBT, DPOPBT
DES These routines are used to save and restore bits before and after conditional
compilation and macro definitions. This enables declarations to be interrupted
without having the partially accumulated BITS value destroyed when expressions
are looked up or string constants created.
CPSHBT Saves current BITS value during conditional compilation.
CPOPBT Restores the value of BITS after conditional compilation.
DPSHBT Saves current BITS value during a macro definition.
DPOPBT Restores the value of BITS after a macro definition.
⊗
↑CPSHBT: QPUSH(CBTSTK,BITS) ;
SETZM BITS ;
POPJ P, ;
↑CPOPBT: QPOP(CBTSTK,BITS) ;
POPJ P, ;
↑DPSHBT: QPUSH(DBTSTK,BITS) ;
SETZM BITS ;
POPJ P, ;
↑DPOPBT: QPOP(DBTSTK,BITS) ;
POPJ P, ;
DSCR CPSHEN, CPSHEY, CPOPET
PRO CPSHEN, CPSHEY, CPOPET
DES These routines are used to allow parser switching in the bodies of WHILEC,
CASEC, FORC, and FORLC statements. This enables one to conditionally compile
these bodies. The routines serve to set and reset a flag which is kept in a
QSTACK pointed at by ENDCTR. This flag indicates whether parser switching
should occur when an ENDC is seen (i.e. if it is terminating a WHILEC, CASEC,
FORC, or FORLC body, then no triggering should occur).
CPSHEN Pushes a -1 on the QSTACK indicating that an ENDC seen with this value
on top of the QSTACK is not to serve as a parser switching trigger.
CPSHEY Pushes a zero on the QSTACK indicating that an ENDC seen with this value on
the top of the QSTACK is to serve as a parser switching trigger.
CPOPET Pops the QSTACK pointed to by ENDCTR when one is done with a particular
ENDC parser switching trigger mode.
⊗
↑CPSHEY: TDZA A,A ;
↑CPSHEN: SETOM A ;
QPUSH(ENDCTR) ;
POPJ P, ;
↑CPOPET: QPOP(ENDCTR) ;
POPJ P, ;
DSCR DCLNT1,DCLNT2
PRO DCLNT1,DCLNT2
DES These routines are used for the DECLARATION and EXPR!TYPE commands.
DCLNT1 Same as DCLNT2 for EXPR!TYPE.
DCLNT2 This routine is used to process a DECLARATION(varname) command which looks
up the varname in the symbol table and returns an integer having the value
of the $TBITS entry in the symbol table. If the variable has not been
declared, then a zero is returned. Note that macro names are not expanded
here. Also, turn off the OWN bit if LPARRAY or SBSCRP are on and
TOPLEV &¬[XWD EXTRNL,GLOBL].
⊗
↑DCLNT1: SKIPA A,GENLEF+1 ; GET SEMBLK FOR EXPR!TYPE
↑DCLNT2: SKIPE A,GENLEF ; GET $TBITS VALUE IF DECLARED - ZERO
MOVE A,$TBITS(A) ; OTHERWISE.
TLNN A,SBSCRP ; TURN OFF OWN BIT IF LPARRAY OR SBSCRP AND
TRNE A,LPARRAY ; TOPLEV &¬[XWD EXTRNL,GLOBL].
TLNN FF,TOPLEV ;
JRST MKINT1 ;
TDNN A,[XWD EXTRNL,GLOBL] ;
TLZ A,OWN ;
MKINT1: TLZ FF,NOMACR ; TURN MACRO EXPANSION BACK ON IF OFF
MKINT2: PUSHJ P,CREINT ; CREATE INTEGER CONSTANT SEMBLK
MOVEM PNT,GENRIG ; SET THE SEMANTIC STACK ENTRY TO
; THE SEMBLK ADDRESS OF THE NUMBER.
POPJ P, ;
DSCR DCLBEG,DCLEND
PRO DCLBEG,DCLEND
DES These routines are used to process EXPR!TYPE command which takes an arbitrary
expression as an argument and returns an integer having the value of the $TBITS
entry in the symbol table for the appropriate type. The difference between it
and the DECLARATION command is that the latter does not expand macro names thus
enabling the user to determine if variables have been used as macro names.
Also, identifiers must have been previously declared if used here.
DCLBEG Saves contents of accumulators and $SBITS values of their contents to
enable recovery from damage done by code generators. Also turn off code
generation, and save ADEPTH, PCNT, and SDEPTH.
DCLEND Restore contents of accumulators and $SBITS values of their contents.
Also restore PCNT and SDEPTH, and make sure ADEPTH has not changed.
⊗
;;#SN# (1 OF 3) 5-30-74 RLS ALLOW RECURSIVE EXPR!TYPE
ZERODATA
EXPCNT: 0
ENDDATA
;;#SN#
↑DCLBEG:
;;#SN# (2 OF 3)5-30-74 RLS ALLOW RECURSIVE EXPR!TYPE
SKIPE EXPCNT ;EXPR!TYPE ENTERED?
JRST [AOS EXPCNT ;YET ANOTHER LEVEL
POPJ P,] ;SO DONT SAVE
AOS EXPCNT ;BUMP COUNT TO 1
;;#SN#
TLNN FF,LPPROG
PUSHJ P,OKSTAC
MOVE A,[XWD ACKTAB,ACKSAV] ; SAVE ACKTAB IN ACKSAV
BLT A,ACKSAV+12 ;
MOVEI D,12 ;
LPAT: MOVE PNT,ACKTAB(D) ; SAVE $SBITS IN SBSAV
MOVE SBITS,$SBITS(PNT) ;
MOVEM SBITS,SBSAV(D) ;
SOJGE D,LPAT ;
SETOM NOEMIT ; TURN OFF EMITTER
MOVE TEMP,ADEPTH ;
MOVEM TEMP,ADPTSV ;
MOVE TEMP,PCNT ;
MOVEM TEMP,PCNTSV ;
MOVE TEMP,SDEPTH ;
MOVEM TEMP,SDPTSV ;
POPJ P, ;
↑DCLEND:
;;#SN# (3 OF 3) 5-30-74 RLS ALLOW RECURSIVE CALLS TO EXPR!TYPE
SOSLE EXPCNT ;BACK TO 0 YET?
JRST [SETZ D, ;NO -- WHY MUST WE ZERO D??
POPJ P,] ;DONT RESTORE YET
;;#SN#
MOVEI D,12 ;
BEGLP: MOVE PNT,ACKTAB(D) ;
CAMN PNT,ACKSAV(D) ; IF ACKTAB IS SAME AS ACKSAV, THEN JUST
JRST AFTRM2 ; RESTORE $SBITS
HRRZ C,$ACNO(PNT) ; CHECK IF AC HAS ALREADY BEEN REMOPED AND
CAIE C,(D) ; IS THUS VALID
JRST AFTREM ; YES
PUSHJ P,CLEAR ;
PUSHJ P,REMOP ;
AFTREM: MOVE PNT,ACKSAV(D) ; RESTORE ACKTAB, $SBITS, AND $ACNO
MOVEM PNT,ACKTAB(D) ;
AFTRM2: MOVE SBITS,SBSAV(D) ;
MOVEM SBITS,$SBITS(PNT) ;
HRRM D,$ACNO(PNT) ;
ENDLP: SOJGE D,BEGLP ;
SETZM NOEMIT ; TURN EMITTER BACK ON
MOVE TEMP,ADPTSV ; IF ADEPTH CHANGED WHILE PROCESSING
CAME TEMP,ADEPTH ; EXPR!TYPE THEN ERROR SINCE PARAMETER
ERR <DRYROT - DCLEND FOR EXPR!TYPE> ; STACK WILL BE OUT OF SYNCH
MOVE TEMP,PCNTSV ;
MOVEM TEMP,PCNT ;
MOVE TEMP,SDPTSV ;
MOVEM TEMP,SDEPTH ;
POPJ P, ;
DSCR CNDRCY, CNDRCN, CNDRCP
PRO CNDRCY, CNDRCN, CNDRCP
DES These routines are used to keep track of whether macros should be
expanded in the false part of conditional compilation. IFCREC is
used to denote the current mode and RECSTK points to the top of
the qstack used to store the currently overridden values of IFCREC
CNDRCY This routine is used to save the current IFC mode and set it
to no expansion of macros in the false part of conditional
compilation,
CNDRCN This routine is used to save the current IFC mode and set it
to expand macros in the false part of conditional compilation.
CNDRCP This routine is used to restore the previous IFC mode.
⊗
↑CNDRCY: QPUSH(RECSTK,IFCREC) ;
SETOM IFCREC ;
POPJ P, ;
↑CNDRCN: QPUSH(RECSTK,IFCREC) ;
SETZM IFCREC ;
POPJ P, ;
↑CNDRCP: QPOP(RECSTK,IFCREC) ;
POPJ P, ;
DSCR PSHLST, POPLST
DES PSHLST, POPLST
DES These routines are used to indicate whether one is in the false part of
conditional compilation or in the conditional compilation parser. This
information is used by the SCANNER so that listing files can hopefully
reflect the true program that is being compiled. The basic action of
the SCANNER is to test the CNDLST flag when it is about to stack a result
on the parse stack and if one is in the conditional compilation parser,
then the listing buffer pointer is reset to the value it had prior to
scanning the parse token in question.
PSHLST This routine is used to indicate that listing should not be happening now.
POPLST This routine is used to indicate that one is to revert to the previous mode
of listing output.
⊗
↑PSHLST: QPUSH(LSTSTK,CNDLST) ; SAVE PREVIOUS COND. COMP. LISTING STATE
SETOM CNDLST ; CEASE LISTING
POPJ P, ;
↑POPLST: QPOP(LSTSTK,CNDLST) ; RESTORE PREVIOUS COND. COMP. LISTING STATE
POPJ P, ;
DSCR SETRDF, SETEDF, DEFOFF
PRO SETRDF, SETEDF, DEFOFF
DES These routines are used indicate when a REDEFINE or an EVALDEFINE are
in progress.
SETRDF This routine turns on the REDEFN flag which indicates that a
REDEFINE of a macro is in progress.
SETEDF This routine turns on the EVLDEF flag which indicates that an
EVALDEFINE is in progress and thus the following macro name is
expanded.
DEFOFF This routine turns off the REDEFN and EVLDEF flags.
⊗
↑SETRDF: SETOM REDEFN ;
POPJ P, ;
↑SETEDF: SETOM EVLDEF ;
POPJ P, ;
↑DEFOFF: SETZM REDEFN ;
SETZM EVLDEF ;
POPJ P, ;
DSCR INTSCN, ASGENT
PRO INTSCN, ASGENT
DES These routines are used to implement the ASSIGNC construct which
allows assignment to macro formals.
INTSCN This routine turns on the ASGFLG flag which indicates that
the next internal representation of a macro is not to be
expanded. Instead the integer value of the macro formal
parameter number is returned.
ASGENT This routine is used to assign the macro body to the macro
formal parameter.
⊗
↑INTSCN: SETOM ASGFLG ;
POPJ P, ;
↑ASGENT: MOVE LPSA,GENLEF+1 ; ASSIGNC NEW BODY
EXCH SP,STPSAV ; SET UP TO USE STRING STACK
MOVSS POVTAB+6 ;
MOVE TBITS,$TBITS(LPSA) ; SEE IF STRING AND IF NOT CONVERT
TRNE TBITS,STRING ; TO A STRING
JRST ASGCON ; IT IS A STRING
PUSH P,$VAL(LPSA) ; NO, CONVERT TO A STRING,
PUSHJ P,REMOPL ; REMOVE NUMERIC SEMBLK
PUSHJ P,CVS ; WILL LEAVE RESULT STRING ON SP-STACK
;; #TA# (CMU = D1=) (2 OF 2) NEED 177 0 AT END OF ACTUAL
PUSH SP,[XWD 0,2]
PUSH SP,[POINT 7,[BYTE (7) 177,0]]
PUSHJ P,CAT
;; #TA#
JRST POPSTR
ASGCON:
PUSH SP,$PNAME(LPSA) ; STACK THE STRING
PUSH SP,$PNAME+1(LPSA) ;
;; #QV# (1 OF )
PUSH SP,[XWD 0,2]
PUSH SP,[POINT 7,[BYTE (7) 177,0]]
PUSHJ P,CAT
EXCH SP,STPSAV ;
PUSHJ P,REMOPL ; REMOVE BODY SEMBLK IF NO ONE ELSE USES IT
;; #QV#
EXCH SP,STPSAV ;
POPSTR:
MOVE LPSA,DEFRNG ; GET SEMBLK OF ACTUAL
MOVE B,GENLEF+2 ; PARAMETER TO BE ASSIGNED TO,
GETIT: SOJE B,GOTIT ; REPLACE ITS $PNAME WITH NEW VALUE
RIGHT ,%RVARB, ; WHICH IS ON TOP OF SP STACK
JRST GETIT ;
GOTIT:
POP SP,$PNAME+1(LPSA) ;
POP SP,$PNAME(LPSA) ;
EXCH SP,STPSAV ;
MOVSS POVTAB+6 ;
;; #QV ! TURN OFF ASGFLG AT APROPRIATE TIME (NOT HERE)
POPJ P,
DSCR LETSET, LETENT
PRO LETSET LENENT
DES EXECS for syntax
LET ident=<reserved word>, .... , ... ;
The semantics of the reserved word is copied into the identifier.
This mechanism could be expanded to allow synonymating idents with
characters, so that characters could be returned to the letter set,
and to allow run-time expressions (LET FOO=1, FOO=FOO+1).
LTR: @IDD EXEC LETSET SCCAN 2 ¬LT1 #QCON
LT1: SG = @RESERVED drarrow EXEC LETENT SCAN ....
⊗
↑LETSET: SETZM BITS ;NO BITS NOW
PUSHJ P,ENTERS ;ENTER IT RANDOMLY
SKIPN LPSA,NEWSYM ;BE CAREFUL
ERR <DRYROT AT LETSET> ;IN CASE ENTERS MAKES A MISTAKE
MOVEM LPSA,GENRIG ;RESULT, SO TO SPEAK
TLZ FF,NOMACR ;TURN OFF SPECIAL
POPJ P, ;DONE
↑LETENT: SKIPE GENLEF
ERR <SYNONYMS FOR RESERVED WORDS ONLY>
;; #MS# LET NOT COPYING TRIGGER BIT
MOVE LPSA,SYMTAB ;PREPARE TO LOOK IT UP
PUSHJ P,SHASH ;LOOK UP SYMBOL AGAIN, PNAME SHOULD
;STILL BE VALID
MOVE TEMP,NEWSYM ;SEMBLK FOR RESERVED WORD
MOVE TEMP,$TBITS(TEMP) ;THE TBITS
;; #MS#
MOVE PNT,GENLEF+2 ;NEW NAME FOR SAME THING
MOVEM TEMP,$TBITS(PNT) ;MAKE THEM EQUIVALENT
POPJ P, ;RETURN
↑TRIGOF: SETZM SWCPRS ; TURN OFF TRIGGERING ON IFC ...
SETOM NODFSW ; TURN OFF TRIGGERING ON DEFINE,
POPJ P, ; REDEFINE, EVALDEFINE, IFC ... SO
; THAT ONE CAN HAVE CONSTRUCTS
; SUCH AS LET DEFINE=REDEFINE
; LET IFC=IFCR
↑TRIGON: SETOM SWCPRS ; TURN ON TRIGGERING ON IFC ...
SETZM NODFSW ; TURN ON TRIGGERING ON DEFINE,
POPJ P, ; REDFINE, AND EVALDEFINE
DSCR TWCOND,SWICHP,SWPOFF,PSWICH,OKEOF
PRO TWCOND SWICHP SWPOFF PSWICH OKEOF
DES EXECS for conditional assembly
TWCOND is responsible for indicating on the parse stack whether or not a
condition is true. In the productions one assumes the condition
is true, and thus if it is false then TWCOND will change the parse
stack token to false.
SWICHP switches parsers from the conditional parser back to the main sail
parser. This entails saving the processor descriptor of the
conditional parser (semantic stack pointer, parse stack pointer,
production stack pointer, and number of calls to scanner that
have still not yet been processed), as well as restoring the
processor descriptor of the main sail parser.
PSWICH does the reverse of SWICHP when one wants to switch from the main
sail parser to the conditional parser. The actual code for this
can be found in SYM at the end of the identifier scan routine.
Note that this is not a procedure but it is described here for
the sake of completeness.
SWPOFF turns the switchparser switch (SWCPRS) off when one would want to
switch to a parser that is already executing. This would typically
happen when one has evaluated a condition to be false; since the
conditional parser would now be in control and is in the process
of swallowing characters until IFC ... ELSEC ... ENDC and nested
occurrences are eliminated and an ENDC or ELSEC appears unnested.
Thus what one has is a flag that says don't interrupt the con-
ditional parser.
OKEOF Is not strictly a part of conditional assembly. It was added to
allow parser to see EOF as a token on some occasions. This allows
code after DONES to scan to EOF, listing rest of file (final END
bug). Will also lead the way to more parsers, like the conditional
parser. OKEOF simply turns on SCNWRD's EOFOK bit...SCANNER
then returns EOF token when appropriate.
⊗
↑TWCOND: GETSEM (1) ; GET SEMANTICS OF ARITHMETIC EXPRESSION
MOVE TEMP,%CFLS1 ; ASSUME COMPARE FALSE (0 OR NOT CONSTANT)
TLNE TBITS,CNST ; CONSTANT?
SKIPN $VAL(PNT) ; ZERO?
MOVEM TEMP,PARRIG ; YES, CHANGE FROM CTRU1 TO CFLS1
POPJ P, ; RETURN
↑SWPOFF: SETZM SWCPRS ; TURN OFF SWITCH PARSEERS FLAG
POPJ P, ; RETURN
↑OKEOF: MOVE TEMP,SCNWRD ;TURN ON EOFOK FOR SCANNER (SCANNER ALWAYS
TLO TEMP,EOFOK ; TURNS IT OFF, SO PRODUCTIONS MUST TURN
MOVEM TEMP,SCNWRD ; IT ON EACH TIME (PROBABLY NOT NECESSARY,
;; #RA# (1 OF 1)
SETOM EOFCEL ;
POPJ P, ; BUT SCANNER SOMETIMES HAS TO TURN IT OFF
; UNDER CURRENT IMPL, SO...)
↑SETFL: MOVE LPSA,GENLEF+2 ; MACRO PSEUDONYM SEMBLK
MOVE LPSA,$VAL2(LPSA) ; ADDRES OF ACTUAL PARAMETER RING SEMBLK
MOVEM LPSA,DEFRN2 ; STORE IT IN DEFRN2
JRST SETFL1 ; GO CONTINUE PREPARING FOR A MACRO CALL
↑SETFR: MOVE LPSA,GENLEF+2 ; GET MACRO PSEUDONYM SEMBLK
PUSHJ P,MKFRLP ; MAKE A FORC LOOP PARAMETER (I.E. LOOP VAR)
POP SP,PNAME+1 ; SECOND WORD OF STRING DESCRIPTOR
POP SP,PNAME ; FIRST WORD OF STRING DESCRIPTOR
EXCH SP,STPSAV ; RETURN STRING POINTER (EXCH IN MKFRLP)
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
GETBLK NEWSYM ; GET A SEMBLK FOR THE FORC LOOP PARAMETER WHICH
HRROI TEMP,PNAME+1 ; IS TREATED AS IF IT IS AN ACTUAL PARAMETER TO
POP TEMP,$PNAME+1(LPSA) ; A MACRO AND IS THUS ALWAYS PUT ON THE STRING
POP TEMP,$PNAME(LPSA) ; RING. NOTE THAT IT IS NOT HASHED AND IS
MOVE TEMP,[XWD CNST,STRING] ; NOT PLACED ON THE STRING CONSTANT RING.
MOVEM TEMP,$TBITS(LPSA) ; THUS WHEN ONE IS THROUGH WITH THE FORC BODY
PUSHJ P,RNGSTR ; ITS LOOP PARAMETER'S SEMBLK IS FREED.
MOVEM LPSA,DEFRN2 ;
SETFL1: EXCH SP,STPSAV ; GET STRING POINTER
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
MOVE LPSA,GENLEF+1 ; GET FORC OR FORLC BODY STRING SEMBLK
PUSH SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR
PUSH SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS
; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
PUSHJ P,CTENDC ; APPEND COND COMP ENDING (" ENDC 177 0")
MOVE LPSA,GENLEF+2 ; LPSA MUST CONTAIN MACRO PSEUDONYM SEMBLK
JRST PRCAL1 ; GO CONTINUE PREPARING FOR A MACRO CALL
↑SETCSE: EXCH SP,STPSAV ; GET STRING POINTER
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
MOVE LPSA,GENLEF+1 ; GET THE CASEC BODY STRING SEMBLK
PUSH SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR
PUSH SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS
; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
PUSHJ P,CTENDC ; APPEND COND COMP ENDING (" ENDC 177 0")
MOVE LPSA,GENLEF+3 ; LPSA MUST CONTAIN MACRO PSEUDONYM SEMBLK
JRST PRECAL ; GO CONTINUE PREPARING FOR A MACRO CALL
↑SETWHL: EXCH SP,STPSAV ; GET STRING POINTER
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
PUSH SP,[XWD 0,4] ; LENGTH OF FOLLOWING STRING
PUSH SP,[POINT 7,[ASCII "IFC "]] ; FIRST WORD OF PSEUDO MACRO
MOVE LPSA,GENLEF+3 ; GET THE CONDITION STRING SEMBLK
PUSH SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR
PUSH SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS
; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
PUSHJ P,CAT ; CONCATENATE
PUSH SP,[XWD 0,7] ; LENGTH OF FOLLOWING STRING
PUSH SP,[POINT 7,[ASCII " THENC "]] ; END OF CONDITION
PUSHJ P,CAT ; CONCATENATE
MOVE LPSA,GENLEF+1 ; GET THE PSEUDO MACRO BODY STRING SEMBLK
PUSH SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR
PUSH SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS
; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
PUSHJ P,CAT ; CONCATENATE
PUSHJ P,CTENDC ; APPEND COND COMP ENDING (" ENDC 177 0")
MOVE LPSA,GENLEF+2 ; LPSA MUST CONTAIN MACRO PSEUDONYM SEMBLK
PRECAL: SETZM DEFRN2 ; WHILEC AND CASEC HAVE NO PARAMETER RINGS
PRCAL1: POP SP,PNAME+1 ; FIRST WORD OF STRING DESCRIPTOR
POP SP,PNAME ; SECOND WORD OF STRING DESCRIPTOR
PUSH P,LPSA ; ENTER CONDITIONAL COMPILATION BODY STRING AND
PUSHJ P,STRINS ; LINK TO MACRO PSEUDONYM SEMBLK
POP P,LPSA ;
HRLM PNT,%TLINK(LPSA) ;
EXCH SP,STPSAV ; RETURN STRING POINTER
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
MOVE TBITS2,SCNWRD ; SYNCH SCAN COMTROL WORD
JRST ACPMED ; GO PREPARE FOR A MACRO CALL (IN SCANNER)
↑CTENDC: PUSH SP,[XWD 0,8] ; LENGTH OF FOLLOWING STRING
PUSH SP,[POINT 7,[BYTE (7) " ","E","N","D","C"," ",177,0]] ; END
; OF PSEUDO MACRO BODY
JRST CAT ; CONCATENATE
↑SWICHM: MOVE LPSA,GENLEF+2 ; PSEUDO MACRO NAME SEMBLK
JRST CONTXT ; PREPARE FOR WHILEC BODY SCAN
↑SWCHFR: MOVE LPSA,GENLEF ; PSEUDO MACRO NAME SEMBLK
PUSHJ P,MKFRLP ; GET NEW FORC LOOP PARAMETER
MOVE LPSA,DEFRNG ; SEMBLK OF PSEUDO MACRO PARAMETER
POP SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
POP SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR
EXCH SP,STPSAV ; RETURN STRING POINTER (EXCH IN MKFRLP)
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
↑SWCHFL: MOVE LPSA,GENLEF ; PSEUDO MACRO NAME SEMBLK
JRST CONTXT ; PREPARE FOR FORC OR FORLC BODY SCAN
↑MKFRLP: EXCH SP,STPSAV ; GET STRING POINTER
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
PUSH P,$VAL2(LPSA) ; CURRENT VALUE OF FORC LOOP PARAMETER
PUSHJ P,CVS ; CONVERT TO STRING
PUSH SP,[XWD 0,2] ; LENGTH OF FOLLOWING STRING
PUSH SP,[POINT 7,[BYTE (7) 177,0]] ; MACRO PARAMETER ENDING
JRST CAT ; CONCATENATE
↑GTSTRT: PUSHJ P,GETCVI ; CONVERT FORC STARTING VALUE TO INTEGER
MOVEM PNT,$VAL2(LPSA) ; STORE IN $VAL2 OF MACRO PSEUDONYM SEMBLK
POPJ P, ; RETURN
↑GTSTEP: PUSHJ P,GETCVI ; CONVERT FORC STEP TO INTEGER
MOVEM PNT,$DATA(LPSA) ; STORE IN $DATA OF MACRO PSEUDONYM SEMBLK
POPJ P, ; RETURN
↑GETERM: PUSHJ P,GETCVI ; CONVERT FORC END VALUE TO INTEGER
MOVE LPSA,GENLEF+2 ; SEMANTICS OF MACRO PSEUDONYM
MOVEM PNT,$DATA2(LPSA) ; STORE IN $DATA2 OF MACRO PSEUDONYM SEMBLK
MOVE PNT,$VAL2(LPSA) ; GET FORC STARTING VALUE
PUSHJ P,TWNUM1 ; GO CHECK IF STARTING VALUE IS OUT OF RANGE
CAMN PNT,%CFLS1 ; STARTING VALUE OUT OF RANGE?
PUSHJ P,FFPUSH ; NO
POPJ P, ; RETURN
↑GETCVI: MOVE PNT,GENLEF+1 ; STRING SEMBLK TO BE CONVERTED TO INTEGER
GENMOV(CONV,INSIST!GETD,INTEGR) ; CONVERT
MOVE PNT,$VAL(PNT) ; GET INTEGER VALUE
MOVE LPSA,GENLEF+2 ; ADDRESS OF MACRO PSEUDONYM SEMBLK
POPJ P, ; RETURN
↑TWNUM: MOVE LPSA,GENLEF+1 ; ADDRESS OF FORC MACRO PSEUDONYM SEMBLK
MOVE PNT,$DATA(LPSA) ; FORC LOOP STEP VALUE
ADDB PNT,$VAL2(LPSA) ; INCREMENT CURRENT FORC LOOP VALUE
↑TWNUM1: SUB PNT,$DATA2(LPSA) ; SUBTRACT FORC LOOP END VALUE
SKIPL $DATA(LPSA) ; STEP NEGATIVE?
MOVN PNT,PNT ; NO, NEGATE STEP
JUMPGE PNT,GPOPJ ; DONE WITH LOOP IF POSITIVE
MOVE PNT,%CFLS1 ; TWIDDLE TO INDICATE END OF FORC LOOP
MOVEM PNT,PARRIG+1 ; SET PARSE STACK TO TWIDDLED VALUE
GPOPJ: POPJ P, ; RETURN
↑GETACT: MOVE LPSA,GENLEF+2 ; ADDRESS OF FORLC MACRO PSEUDONYM SEMBLK
HRLZI TEMP,1 ; SET PARAMETER COUNT TO ZERO
MOVEM TEMP,$VAL(LPSA) ; STORE IT (incredibly imaginative comment)
MOVE TBITS2,SCNWRD ; SYNCH SCAN CONTROL WORD
PUSHJ P,SCNACT ; SCAN A LIST OF ACTUAL PARAMETERS WHICH
; CAN HAVE A SPECIAL DELIMITER DECLARATION
; (IN SCANNER)
MOVE TEMP,DEFRN2 ; DEFRN2 POINTS TO RING OF ACTUAL PARAMETERS
MOVEM TEMP,$VAL2(LPSA) ; STORE IT IN $VAL2 OF FORLC MACRO PSEUDO-
; NYM SEMBLK SO THAT THE MACRO BODY CAN BE
; PROPERLY SCANNED FOR PARAMETER SUBSTITU-
; TIONS
POPJ P, ; RETURN
↑TWACT: MOVE LPSA,DEFRNG ; GET FORLC ACTUAL PARAMETER RING
HRRZ LPSA,%RVARB(LPSA) ; GET NEXT PARAMETER IF NOT DONE
JUMPN LPSA,.+3 ; FORLC ACTUAL PARAMETER LIST EXHAUSTED
MOVE TEMP,%CFLS1 ; TOKEN TO BE TWIDDLED
MOVEM TEMP,PARRIG+1 ; SET PARSE STACK STRAIGHT
PUSH P,LPSA ; REMOVE CURRENT FORLC PARAMETER FROM THE STRING
MOVE LPSA,DEFRNG ; RING AND FREE ITS STRING SEMBLK
PUSHJ P,URGSTR
POP P,LPSA;
FREBLK DEFRNG ;
MOVEM LPSA,DEFRNG ; SET DEFRNG TO CURRENT ACTUAL PARAMETER
POPJ P, ; RETURN
↑TWCSCN: MOVE TEMP,GENLEF+3 ; ADDRESS OF CASEC MACRO PSEUDONYM SEMBLK
SOSE $VAL2(TEMP) ; RIGHT CASEC?
POPJ P, ; NO, RETURN
PUSHJ P,CPSHEN ; SET ENDC DOESN'T TRIGGER A PARSER SWITCH FLAG
SETOM SWCPRS ; PARSER SWITCHING IS OK (I.E. IFC IN BODY OF CASEC
; TO BE EXECUTED)
MOVE TEMP,%CTRU1 ; TWIDDLE SO NEXT CASEC WILL BE SCANNED
MOVEM TEMP,PARRIG ; SET PARSE STACK STRAIGHT
POPJ P, ; RETURN
↑FREMBN: MOVE A,GENLEF+2 ; GET RID OF FORMAL PARAMETER LIST TO FORC
MOVE LPSA,$ACNO(A) ; AND WHICH IS NEVER EXECUTED AS
PUSHJ P,KILLST ; WELL AS RESTORE THE PROPER LEVEL AND
MOVE LPSA,GENLEF+2 ; VARB
PUSHJ P,CLENUP ;
JRST FRMBFF ;
↑FREMBF: SKIPA LPSA,GENLEF ; FORC, AND FORLC MACRO PSEUDONYM SEMBLK
↑FREMBW: MOVE LPSA,GENLEF+2 ; WHILEC MACRO PSEUDONYM SEMBLK ADDRESS
FRMBFF: PUSH P,LPSA ; CHECK IF THROUGH WITH PSEUDO MACRO STRING AND IF
HLRZ LPSA,%TLINK(LPSA) ; YES FREE ITS SEMBLK SO THE STRING WILL BE
PUSHJ P,REMOPL ; GARBAGE COLLECTED
PUSHJ P,BLKFRE ; FREE MACRO PSEUDONYM SEMBLK
MOVEI TEMP,2 ; AT THIS POINT ONE STILL HAS 177,0 TO SCAN SO SET
HRRM TEMP,PNEXTC-1 ; PNEXTC-1 TO POINT TO THE 177,0 AS A STRING SO IT
POPJ P, ; WON'T BE LOST IN CASE OF A GARBAGE COLLECTION
↑FRMBCE:MOVE LPSA,GENLEF+3 ; CASEC SEMBLK ADDRESS
SKIPLE $VAL2(LPSA) ; CHECK IF NONE OF THE CASEC CASES WERE
PUSHJ P,CLENUP ; EXECUTED; IF SO RESTORE VARB AND LEVEL
FREBLK GENLEF+3 ; DELETE CASEC PSEUDONYM SEMBLK
POPJ P, ; RETURN
↑FRMBCT: MOVE LPSA,GENLEF+2 ; LAST TRUE CASEC BODY SEMBLK
HLRZ LPSA,%TLINK(LPSA) ; LAST TRUE CASEC BODY SEMBLK
PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS
; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
MOVE LPSA,GENLEF+2
HRRZS %TLINK(LPSA) ; MACRO PSEUDONYM NO LONGER HAS A BODY LINK
POPJ P, ; RETURN
CLENUP: MOVE TEMP,$ADR(LPSA) ; RESTORE VARB AND LEVEL WHEN CASEC, FORC,
MOVEM TEMP,VARB ; AND FORLC ARE NOT EXECUTED. EXPECTS
SOS LEVEL ; LPSA TO CONTAIN THE ADDRESS OF THE
;; #SZ# CMU =C7= SAVE LPSA OVER CALL TO FREBUK
PUSH P,LPSA ; SAVE OVER CALL TO FREBUK
PUSHJ P,FREBUK
POP P,LPSA
POPJ P,
;; #SZ#
↑TMACIN: SKIPE PRSCON ; DETERMINE WHICH PARSER IS CURRENTLY SUSPENDED AND
SKIPA A,SSCWSV ; GET A POINTER TO ITS SCNWRD STACK. THIS IS USED
MOVE A,CSCWSV ; TO SET THE MACIN BIT IN SYNCH WITH MACROS THAT
POPJ P, ; MIGHT HAVE ENDED WHILE THE SUSPENDED OR MOST
; RECENTLY ACTIVATED PARSER WERE INACTIVE.
↑TOMACN: PUSHJ P,TMACIN ; CHANGE MACIN BIT OF PARSER TO BE RESUMED TO
LDB TBITS2,[POINT 1,SCNWRD,6] ; THE VALUE OF THE MACIN BIT OF THE
DPB TBITS2,[POINT 1,(A),6] ; CURRENT PARSER.
POPJ P, ;
↑FRMACN: PUSHJ P,TMACIN ; CHANGE THE MACIN BIT OF THE CURRENT PARSER TO
LDB TBITS2,[POINT 1,(A),6] ; THE VALUE OF THE MACIN BIT OF THE SUSPENDED
DPB TBITS2,[POINT 1,SCNWRD,6] ; PARSER.
POPJ P, ;
SUBTTL EXECS for Entry Declaration
DSCR ENTMAK, ENTOUT
PRO ENTMAK ENTOUT
DES EXECS for syntax
ENTRY id1, id2, ...., ... ;
Must appear before initial BEGIN
SEE comment below DSCR for details
⊗
Comment ⊗ ENTRY code -- has two functions:
1. Denote that this compilation is not the main program
but a collection of separately compiled procedures.
2. Create an entry block so that these programs
can be loaded from a library.
The syntax:
BB0: ENTRY drarrow EXEC ENTENT SCAN 2 ¬ ENT
BEGIN drarrow BLAT BEGIN EXEC ENTOUT DWN SCAN ¬DS
...
ENT: @I , drarrow EXEC ENTMAK SCAN 2 ¬ ENT
@I ; drarrow EXEC ENTMAK SCAN ¬ BB0
⊗
↑ENTENT: TLZE FF,MAINPG ;NO STARTING ADDRESS FOR THIS PROGRAM
HLLZS ENTTAB ;RESET FIRST TIME IN
POPJ P,
↑ENTMAK: HRL LPSA,PNAME ;COUNT
HRR LPSA,PNAME+1 ;BYTE POINTER FOR ENTRY SYMBOL
PUSHJ P,RAD52 ;MAKE RADIX50 FOR ENTRY
AOS B,ENTTAB ; PTR TO NEXT ENTRY
HRRZS B ;CLEAR LEFT HALF
MOVEM A,ENTTAB+1(B) ;TO ENTRY TABLE
CAIGE B,22 ;FULL?
POPJ P, ;NO
↑ENTOUT:
MOVEI B,ENTTAB ;PUT OUT BLOCK IF THERE IS
TLNN FF,MAINPG ; ONE
JRST GBOUT
POPJ P, ;THERE IS NONE FOR SURE
SUBTTL EXECS for Storage Allocation at end of Procedure
DSCR ALOT
DES Allocation routine -- called by PRUP and DONES EXECS, allocates
storage, issues fixups and symbols for all locals in Procedure
(outer Block)
PAR VARB-rings on BLKLIS Qstack
RES ALIMS, ALOCALS, SLIMS, SLOCALS, LLIMS, LLOCALS as described
in subsequent comments
SEE comment below DSCR for details
⊗
COMMENT ⊗
This is the code invoked to allocate space for variables on the
VARB ring. Symbols are also output to the loader, for use by DDT and
the world. As each block is closed, the portion of the VARB ring developed
for that block is saved by a pointer in the table BLKLIS, and the count
BLKIDX is incremented. It is the job of this code to run through all
the VARB information stored on this list, and allocate.
There is a bit in FF, called ALLOCT which determines whether
this code actually allocates storage, or merely counts things.
The counts are necessary for deciding how exit and entry code for
recursive procedures should be generated. These counts are:
ALOCAL (arithmetic stack locals) and SLOCAL (string stack
locals). FIRSYM and LSTSYM point to the first and last symbols allocated.
⊗
ZERODATA (VARIABLE-ALLOCATION VARIABLES)
COMMENT ⊗
ALIMS -- [Semantics of last,Semantics of first] -- set up by ALLOT
to indicate the range of non-string variables allocated. This
is used by PROCED after the first (non-allocating) call on ALLOT
and before the second (allocating) call, to set up saving
and restoring instructions (BLT) for these variables for
recursive Procedures. The non-allocating run allows these extra
instructions to be inserted before fixed locations are assigned
to the variables (see ALLOT's DSCRs).
⊗
↑↑ALIMS: 0
;ALOCALS -- a count of the number of non-string locals -- set up
; for the same reasons given above for ALIMS
↑↑ALOCALS: 0
;BLKCNT -- temp used when outputing symbol names -- see DOSYM's
; DSCR for details
?BLKCNT: 0
;FIRSYM -- Semantics of first variable allocated by ALOT -- used to
; set up ALIMS, SLIMS, LLIMS
?FIRSYM: 0
;LLIMS -- ALIMS-like thing for sets -- ALIMS includes LLIMS in its
; range -- used to put together Set Link Blocks -- see ALLOT
?LLIMS: 0
;LLOCAL -- ALOCAL-type count of number of Sets this Procedure
?LLOCAL: 0
;LSTSYM -- Semantics of last variable allocated by ALOT -- used to
; set up ALIMS, SLIMS, LLIMS
?LSTSYM: 0
;SLIMS -- ALIMS-like thing for strings. Used for above-
; mentioned purposes; also to put together String Link Blocks
; See ALLOT, LNKOUT
↑↑SLIMS: 0
;SLOCALS -- ALOCALS-type count for # Strings this Procedure
↑↑SLOCALS: 0
THSLVL: 0
ENDDATA
↑ALOT: ;ROUTINE TO HANDLE ALLOCATION
;OF CORE AND THINGS FOR VARIABLES.
SETZM FIRSYM
TLNN FF,ALLOCT ;ALLOCATING REALLY?
JRST ALSYMS ; NO, IGNORE ADCONS THIS TIME AROUND
;ALLOCATE ADDRESS CONSTANTS. INFORMATION ABOUT THEM IS
;SAVED ON THE VARB RING HOMED AT ADRTAB. SEE PROCED
;FOR DETAILS OF HOW THE ADDRESS CONSTANTS ARE USED.
ADCGO: HRRZ LPSA,TPROC ;GET LEVEL OF PROCEDURE WHOSE LOCALS
LDB TEMP,PLEVEL ; ARE BEING DEFINED
MOVEM TEMP,THSLVL
HRRZ LPSA,ADRTAB ;ADDRESS CONSTANTS.
JUMPE LPSA,ALSYMS ;NONE
RADA: MOVE SBITS,$SBITS(LPSA) ;IF A TEMP, IT IS IDENTIFIED BY
TLNN SBITS,ARTEMP ;ITS SEQUENCE NO, ELSE BY SEMANTIC ADR
JRST RADAA ;NOT A TEMP
MOVE A,$PNAME(LPSA) ;THE ID NO FOR THIS TEMP
MOVE PNT,TTEMP ;SEARCH THE TEMP LIST FOR IT
RADLP: JUMPE PNT,NOUNLK ;NOT THERE, TRY LATER
CAMN A,$PNAME(PNT) ;IS THIS THE RIGHT INFO?
JRST RADAB ; YES, PUT OUT ADCON
HLRZ PNT,%RVARB(PNT) ;NO, KEEP LOOKING
JRST RADLP
RADAA: HLRZ PNT,%TLINK(LPSA) ;GET POINTER TO
RADAB: PUSHJ P,GETAD ;SEMANTICS OF SYMBOL WHOSE AD IS CONED.
TLNE SBITS,CORTMP ;IS THIS A CORE TEMP?
JRST OKRADA ; YES, PUT OUT THE ADCON
TLNE SBITS,ARTEMP
; ***** BUG TRAP
ERR <DRYROT -- RADA>,1
TLNE TBITS,CNST
JRST OKRADA ;EACH WILL APPEAR BUT ONCE
TDZ SBITS,[¬LLFLDM] ;GET LEVEL ONLY
CAMGE SBITS,THSLVL ;IF ADCON CORRESPONDS TO
JRST NOUNLK ;SOMETHING IN THIS PROC, PUT IT OUT
OKRADA:
HRLZ B,$ADR(LPSA) ;ADCON FIXUP
JUMPE B,RADC ;WAS NOT USED.
HRR B,PCNT
PUSHJ P,FBOUT ;FIXUP FOR THE ADCON.
HLL A,$ADR(LPSA) ;TYPE BITS TO INSERT.
HRRI A,FXTWO!NOUSAC
;; #NQ# ! A STRING ITEMVAR IS NOT A STRING
TDNN TBITS,[SBSCRP,,ITMVAR] ;IF ¬(SBSCRP OR ITEMVAR)AND STRING
TRNN TBITS,STRING ; USE 2D WORD FIXUP
TRZ A,FXTWO ;ELSE REGULAR OLD FIXUP
;;#SG# THE TYPE BITS MAY BE AN "IMMEDIATE-ABLE" OP CODE
PUSH P,OPDUN ;PARANOIA STRIKES DEEP
SETOM OPDUN
PUSHJ P,EMITER ;USE HIM TO OUTPUT THE WORD.
POP P,OPDUN
;;#SG#
RADC: PUSHJ P,URGADR ;REMOVE FROM ADRTAB
FREBLK (LPSA)
NOUNLK: LEFT ,%RVARB,ALSYMS ;LOOP UNTIL DONE.
JRST RADA
Comment ⊗
NOW ALLOCATE STORAGE FOR VARIABLES.
When a block has been compiled, the pointer to its block entry (and thus to
its VARB ring of locals) is placed in the next free location in BLKLIS
(using BLKIDX QPDP). BLKIDX is cleared at the beginning of each procedure
compilation, and the old value is stored. In all that follows, all and only
those blocks whose pointers lie in the current BLKLIS will be processed.
In order to keep things together for BLT'ing on and off the stacks, strings
are allocated first. Then arrays. Then all else. The routine "ALLO" is
called to actually look for things to allocate. It uses the mask set up in
TBITS2.
⊗
ALSYMS: MOVEI TBITS2,STRING ;FIRST ALLOCATE STRINGS.
REN <
PUSHJ P,LOSET ;SWITCH TO DATA SEGMENT
>;REN
SETZM CSPOS ;SET STACK DISPL=0
PUSHJ P,ALLO ;GO DO IT.
LSH PNT2,1
MOVEM PNT2,SLOCAL ;SAVE COUNT OF STRINGS ALLOCATED.
MOVEM A,SLIMS ;LIMITS OF SYMBOLS.FOR STRINGS
MOVE PNT2,CSPOS ;
MOVEM PNT2,SSDIS ;STRING STACK DISPL DUE TO LOCALS
MOVEI PNT2,2 ;FOR MCSP SIZE
SKIPE SIMPSW ;IF SIMPLE
HRRZI PNT2,0 ;THEN NO MSCP
MOVEM PNT2,CSPOS ;SET CNTR
AL1: SETZM FIRSYM
SETZM LSTSYM
MOVEI TBITS2,SET!LSTBIT ;ALLOCATE SETS FIRST AMONG "ARITHMETICS"
PUSHJ P,ALLO
HRLZM PNT2,LLOCAL ;FOR SETS ONLY.
MOVEM A,LLIMS
MOVEM PNT2,ALOCAL ;START LOCAL COUNT FOR ARITHS.
MOVSI TBITS2,SBSCRP ;ALLOCATE ARRAYS.
PUSHJ P,ALLO
ADDM PNT2,ALOCAL ;COUNT OF ARITH. LOCALS.
MOVEI TBITS2,-1 ≠ (STRING!LSTBIT!SET) ;ALL OTHERS.
PUSHJ P,ALLO
ADDM PNT2,ALOCAL ;AND UPDATE LOCAL COUNT
PUSHJ P,TMPALO ;ALLOCATE TEMPS.
ADDM PNT2,ALOCAL ;AND UPDATE LOCAL COUNT
MOVE A,FIRSYM
HRL A,LSTSYM
MOVEM A,ALIMS ;LIMITS OF ARITH. LOCALS.
MOVE PNT2,CSPOS ;PICK UP STACK LOC
MOVEM PNT2,ASDIS ;SAVE IT AS ARITH STACK DISPL FOR LOCALS
REN <
PUSHJ P,HISET ;BACK TO CODE SEGMENT
>;REN
TLNN FF,ALLOCT ;ACTUALLY ALLOCATING ?
POPJ P, ;NO -- DONE COMPLETELY.
HRRZ PNT2,TPROC ;THIS PROCEDURE
BAIL<
SKIPG TEMP,BAILON
JRST .+2 ;USE REGULAR TEST
TRNN TEMP,BBPDSM ;SKIP IF WANT PD FOR SIMPLE--THUS PD EVERY TIME
>;BAIL
SKIPN SIMPSW ;IF SIMPLE, NO PD
PUSHJ P,PDOUT ;PUT OUT PROC DESC
AL2: SETZM TTEMP ;RESTART TEMP LIST.
SETZM BLKCNT ;NO BLOCKS LOOKED AT OR ALLOCATED
QBEGIN (BLKIDX) ;FIND BOTTOM ELEMENT IN BLKLIM QSTACK
NOBAIL<
JUMPE B,CRECHK ; NO SYMBOLS TO ALLOCATE
>;NOBAIL
BAIL <
COMMENT ⊗
Here lies the Bail symbol outputing stuff. Currently, it puts out 1 file:
.SM1 Variable length tables of information
⊗
BAISYM:
TLNE FF,BINARY ;ARE WE PUTING OUT SYMBOLS?
SKIPG BAILON ;IS DEBUGGER ACTIVE?
JRST DOSYM ;NOPE
PUSH P,PNT2
PUSH P,TBITS2
MOVE LPSA, TPROC ;CURRENT PROCEDURE
MOVE TBITS,$TBITS(LPSA) ;TYPE
TLNE TBITS,EXTRNL ;DON'T BOTHER WITH EXTERNAL PROCS
JRST [CAIE LPSA,RESYM ;IF THE OUTER BLOCK PROC,DO IT
JRST BLCDUN
JRST .+1]
SETZ SBITS,
HLLM SBITS,BCORDN ;WE ARE NO LONGER DOING COORDS
; SINCE WE WANT SYMBOLS PUT OUT SO THAT
;INNERMOST BLOCK SYMBOLS APPEAR FIRST, WE DELAY THE
;FORMALS UNTIL AFTER THE LOCALS
BLCKDN:
QTAKE (BLKIDX) ;GET NEXT BLOCK
JRST BFORMS ;NO MORE BLOCK!
HRRZ LPSA,A ;GET THE BLOCK SEMBLK
MOVE TEMP,BAILON ;SEE IF THIS BLOCK IS WANTED:
TRNE TEMP,BBSYM ;ALL SYMBOLS WANTED ALL THE TIME?
JRST BLCKD1 ;YES
MOVE TBITS,$VAL(LPSA) ;THE "OR" OF ALL SYMBOLS DEFINED HERE
TLNE TBITS,INTRNL ;ANY INTERNALS HERE?
JRST BLCKD1 ;YES, ALWAYS PUT THEM OUT
HRRZ SBITS,%RVARB(LPSA) ;SEMBLK OF FIRST VARIABLE, IF ANY
JUMPE SBITS,BLCKDN ;IF NO VARS AND NOT(BBSYM), SKIP BLOCK TOO
BLCKD1: SETZ SBITS,
PUSHJ P,VALOUT ;END PREVIOUS BLOCK
MOVEI SBITS,BAIBLK
PUSHJ P,VALOUT ;START BLOCK NAME
SKIPE $PNAME(LPSA) ;DOES BLOCK ALREADY HAVE A NAME?
JRST BBNMYS ;YES
;CREATE A NAME FOR THIS BLOCK -- TRICKY!
PUSHJ P,INSET ;USES ONLY TEMP
HLRZ PNT2,%TLINK(LPSA) ;SECOND BLOCK SEMBLK
HRRZ TBITS,$VAL2(PNT2) ;COORDINATE AT BEGIN
MOVEI TEMP,"B"
IDPB TEMP,TOPBYTE(USER) ;NAME BEGINS WITH "B"
PUSH P,B ;SAVE FOR THE QTAKE AT BLCKDN
MOVEI B,[IDPB TBITS,TOPBYTE(USER) ;ROUTINE TO DISPENSE CHARS
POPJ P,]
MOVEI PNT2,4 ;4 CHARS
PUSHJ P,FRNPD ;GET ASCII
POP P,B ;GET OUR AC BACK
HRROI TEMP,5 ;NAME IS 5 CHARS LONG
MOVEM TEMP,$PNAME(LPSA) ;LENGTH OF NAME
BBNMYS: HRRZ SBITS,$PNAME(LPSA) ; # CHARS
ADDI SBITS,4
IDIVI SBITS,5 ; # WORDS
HRRZ PNT2,$VAL2(LPSA) ;DDT LEVEL
DPB PNT2,[POINT 6,SBITS,35-6]
HLRZ TEMP,%TLINK(LPSA) ;SECOND BLOCK SEMBLK
HRL SBITS,$VAL2(TEMP) ;COORDINATE
PUSHJ P,VALOUT ;FIRST WORD OF BLOCK BLOCK
HLR SBITS,$VAL2(LPSA) ;ADDR OF FIRST WORD OF CODE
HLL SBITS,$VAL2(TEMP) ;ADDR OF LAST WORD OF CODE
PUSHJ P,VALOUT ;SECOND WORD
PUSHJ P,NAMOUT ;FOLLOWED BY NAME
HRRZ SBITS,%RVARB(LPSA)
JUMPE SBITS,BLCKDN ;TEST FOR ANY VARIABLES
LOCAS: HRRZ LPSA,%RVARB(LPSA) ;GET NEXT VARIABLE
JUMPE LPSA,BLCKDN ;END OF LOCALS
MOVE TBITS,$TBITS(LPSA)
TRNE TBITS,SET ;DON'T LET KILL SETS OUT
TRNN TBITS,INTEGR
TLNE TBITS,DEFINE ;DON'T PUT OUT ANY OF THESE
JRST LOCAS
TLNE TBITS,EXTRNL
SKIPE $ADR(LPSA)
JRST .+2
JRST LOCAS ;EXTERNALS ONLY IF REFERENCED
TRNE TBITS,PROCED ;PROCEDURES ONLY IF EXTERNAL
TLNE TBITS,EXTRNL
JRST .+2
JRST LOCAS
MOVE TEMP,BAILON
TLNN TBITS,INTRNL ;SKIP IF INTERNAL
TRNE TEMP,BBSYM ;SKIP IF NOT ALL SYMBOLS WANTED
JRST .+2 ;SYMBOL IS INTERNAL OR ALL ARE WANTED
JRST LOCAS
HRRZ SBITS,$PNAME(LPSA) ; # CHARS
ADDI SBITS,4
IDIVI SBITS,5 ; # WORDS
PUSHJ P,VALOUT ; FIRST WORD FOR VARIABLE
MOVE TBITS,$TBITS(LPSA) ;TYPE BITS FOR VARIABLE
HRRZ SBITS,$ADR(LPSA) ;ADDR OF VARIABLE
TRNE TBITS,ITEM ;ITEMS GET SPECIAL TREAMENT
JRST [TLO SBITS,BITEM!BBILTN
HRRZ TBITS,$VAL2(LPSA) ;GET INTEGER CONST SEMBLK
HRR SBITS,$VAL(TBITS) ;GET THE ITEM NUMBER
JRST .+2]
PUSHJ P,TYPMNG ;***ALL THE TYPE MUNGING GOES HERE
PUSHJ P,VALOUT
PUSHJ P,NAMOUT ;PUT OUT THE NAME
JRST LOCAS
BFORMS:
MOVE LPSA,TPROC ;FIRST PROCEDURE SEMBLK
HRRZ PNT2,$VAL(LPSA) ;THE PD SEMBLK
JUMPE PNT2,BLCDUN ;JUMP IF NO PD (I.E., BBPDSM OFF)
MOVE TBITS,$TBITS(LPSA) ;TYPE BITS FOR THIS PROC
TRNE TBITS,FORTRAN ;FORTRAN PROCEDURE?
JRST BLCDUN ;YES. GIVE UP
SETZ SBITS,
PUSHJ P,VALOUT ;FLAG END OF PREVIOUS BLOCK
MOVEI SBITS,BAIPRC
PUSHJ P,VALOUT ;START BLOCK INFO
HRRZ SBITS,$PNAME(LPSA) ; # CHARS
ADDI SBITS,4
IDIVI SBITS,5 ;# WORDS
;;#%%# ! PNT2 GOT CLOBBERED BY THAT DIVIDE JFR 11-13-74
HRRZ PNT2,$VAL(LPSA) ;THE PD SEMBLK
HLL SBITS,$VAL(PNT2) ;COORDINATE
HLRZ TEMP,%TLINK(LPSA) ;SECOND PROC SEMBLK
HRRZ TEMP,$VAL2(TEMP) ;DDT LEVEL
DPB TEMP,[POINT 6,SBITS,35-6]
TRO SBITS,400000 ;FLAG FOR PROCEDURE
PUSHJ P,VALOUT ;FIRST WORD
HRL SBITS,$ACNO(PNT2) ;LOC OF JRST EXIT (=LAST WORD OF CODE)
HLR SBITS,$VAL2(LPSA) ;PCNT AT PRDEC (=FIRST WORD OF CODE)
PUSHJ P,VALOUT ;SECOND WORD
MOVE TBITS,$TBITS(LPSA)
HRLI SBITS,BPROCED ;THIS IS A PROCEDURE
PUSHJ P,TYPMNG ;GET THE BITS FOR IT
HRR SBITS,$ADR(PNT2) ;PDA
BFORM1: PUSHJ P,VALOUT ;THIRD WORD
PUSHJ P,NAMOUT ;NAME
HLRZ LPSA,%TLINK(LPSA) ;2ND PROC BLOCK
HLRZ LPSA,%TLINK(LPSA) ;1ST FORMAL PARM
FORMS: JUMPE LPSA,BLCDUN ;ANY MORE?
HRRZ SBITS,$PNAME(LPSA) ; # CHARS
ADDI SBITS,4
IDIVI SBITS,5 ; # WORDS
PUSHJ P,VALOUT
HRRZ SBITS,$ADR(LPSA) ;PUT ADR IN RH & BITS IN LH
MOVE TBITS,$TBITS(LPSA)
TRNE TBITS,PROCED ;PROCEDURES GET SPECIAL TREATMENT
JRST [TLO SBITS,BPROCED!BREF
JRST .+2]
PUSHJ P,TYPMNG ;******* TYPE MUNGING GOES HERE
PUSHJ P,VALOUT
PUSHJ P,NAMOUT ;PUT OUT NAME
HRRZ LPSA,%RVARB(LPSA) ;GET NEXT FORMAL
JRST FORMS
BLCDUN: QBEGIN (BLKIDX) ;RESET BLKLIS
POP P,TBITS2
POP P,PNT2
JUMPE B,CRECHK ;JUMP IF NO SYMBOLS TO PUT OUT
JRST DOSYM ;GO GIVE RAID IT'S SYMBOLS
↑NAMOUT: HRRZ PNT2,$PNAME(LPSA) ;CHAR COUNT
MOVE SBITS2,$PNAME+1(LPSA) ;POINTER
NN: MOVE D,[POINT 7,SBITS]
SETZ SBITS, ; CLEAR TEMP DESTINATION
MOVEI C,5 ; # CHARS PER WORD
NN1: ILDB A,SBITS2 ;LOAD CHAR
IDPB A,D ;DEPOSIT INTO SBITS
SOSE C ;CHECK IF FULL WORD FORMED
SOJG PNT2,NN1 ;CHECK IF DONE WITH NAME
PUSHJ P,VALOUT ;WRITE FULL WORD
SOJG PNT2,NN ;START NEW WORD IF NOT DONE
POPJ P,
↑VALOUT:
NOTENX< SOSG SM1CNT
OUTPUT SM1,
IDPB SBITS,SM1PNT
POPJ P,
>;NOTENX
TENX< IDPB SBITS,SM1PNT ;PLUNK IT DOWN
SOSG SM1CNT
PUSHJ P,VALOU1 ;DUMP BUFFER
POPJ P,
↑VALOU1: PUSH P,1
PUSH P,2
PUSH P,3 ;SAVE THESE ACS
MOVE 1,SM1JFN
MOVE 2,[POINT 36,SM1BUF]
MOVE 3,SM1CNT
SUBI 3,SM1SIZ ;AC3=NEGATIVE WORD COUNT
JSYS SOUT
MOVE 1,[POINT 36,SM1BUF]
MOVEM 1,SM1PNT
MOVEI 1,SM1SIZ
MOVEM 1,SM1CNT
POP P,3
POP P,2
POP P,1
POPJ P,
>;TENX
COMMENT ⊗
TYPMNG is the routine that translates Compiler types into Bail types.
Procedures and items have been filterd out ahead of time. There are
3 trees:
(right branch indicates that SAIL bit was off)
COMPLEX TYPE:
_______________ SBSCRP___________________
| |
_____ITMVAR___________ ___________ITMVAR______
| ↓ | ↓
____LPARRY_______ BARRY _____LPARRY__________ BSIMPL
↓ ↓ ↓ ↓
BARITA BITMAR BARITM BITMV
SIMPLE TYPE:
________________________SET______________
| |
_____LSTBIT________ ______________STRING________
↓ | ↓ |
BLIST _______FLOTNG____ BSTRNG _______________INTEGR______
↓ ↓ ↓ |
BCNTXT BSET BINTGR ________FLOTNG____
↓ |
BREAL ______LABEL___
↓ ↓
BLABEL BLAMDA
ACCESS TYPE:
REFRNC___________________
| ↓
| BREF
EXTRNL!PROCED____________
| |
| |
| ______PROCED______
| ↓ ↓
| BXPROC BEXTRN
VALUE____________________
| ↓
| BSTAK
OWN_____________________
| ↓
| BBILTN
<RECSW>__________________
| ↓
| BSTAK
SBSCRP!SET__________________
| ↓
↓ BALLOC
BBILTN
⊗
BITDATA (BAIL TYPES)
;COMPLEX
BSIMPLE ←←0
BARRY ←←1
BITMV ←←2
BARITM ←←3
BITMAR ←←4
BARITA ←←5
BPROCED ←←6
BITEM ←←7
BBLOCK ←←BPROCED+10;
;SIMPLE
BLAMDA ←←00
BINTGR ←←10
BREAL ←←20
BSTRNG ←←30
BLIST ←←40
BSET ←←50
BCNTXT ←←60
BLABEL ←←70
;ACCESS
BBILTN ←←000
BREF ←←100
BALLOC ←←200
BSTAK ←←300
BEXTRN ←←400
BXPROC ←←500
;SM1 BLOCK TYPES
↑↑BAIFIL←←1 ;FILE INFO BLOCK
↑↑BAICRD←←2 ;COORDINATE BLOCK
↑↑BAIBLK←←3 ;BLOCK NAME, THEN IDENTIFIERS
↑↑BAIPRC←←4 ;PROCEDURE NAME, THEN PARAMETERS
ENDDATA
TYPMNG: ;INPUT TYPE IN TBITS, OUTPUT IN SBITS
TLNE TBITS,SBSCRP
JRST B1.
TRNE TBITS,ITMVAR
JRST B2.
TLO SBITS,BSIMPL
JRST SIMTYP
B1.: TRNE TBITS,ITMVAR
JRST B3.
TLO SBITS,BARRY
JRST SIMTYP
B2.: TRNE TBITS,LPARRAY
TLOA SBITS,BARITM
TLO SBITS,BITMV
JRST SIMTYP
B3.: TRNE TBITS,LPARRAY
TLOA SBITS,BARITA
TLO SBITS,BITMAR
SIMTYP: TRNE TBITS,SET
JRST B4.
TRNE TBITS,INTEGR
JRST [TLO SBITS,BINTGR
JRST ACCTYP]
TRNE TBITS,STRING
JRST [TLO SBITS,BSTRNG
JRST ACCTYP]
TRNE TBITS,FLOTNG
JRST [TLO SBITS,BREAL
JRST ACCTYP]
TRNE TBITS,LABEL
TLOA SBITS,BLABEL ;WE ASSUME $ADR HAS ADDRESS OF LABEL...
TLO SBITS,BLAMDA
JRST ACCTYP
B4.: TRNE TBITS,LSTBIT
JRST [TLO SBITS,BLIST
JRST ACCTYP]
TRNE TBITS,FLOTNG
TLOA SBITS,BCNTXT
TLO SBITS,BSET
ACCTYP: TLNE TBITS,REFRNC
JRST [TLO SBITS,BREF
POPJ P,]
TLNE TBITS,EXTRNL
JRST [TRNE TBITS,PROCED
TLOA SBITS,BXPROC
TLO SBITS,BEXTRN
POPJ P,]
TLNE TBITS,VALUE
JRST [TLO SBITS,BSTAK
POPJ P, ]
TLNE TBITS,OWN
JRST [TLO SBITS,BBILTN
POPJ P, ]
SKIPE RECSW ;RECSW IS ON IF DURING REC PROC COMPS
JRST [TLO SBITS,BSTAK
TRO SBITS,400000 ;SIGNALS THAT THE STAC INC IS NEGATIVE
POPJ P, ]
TDNE TBITS,[XWD SBSCRP,SET]
TLOA SBITS,BALLOC
TLO SBITS,BBILTN
POPJ P,
>;BAIL
Comment ⊗
; NOW ISSUE SYMBOLS FOR THIS PROCEDURE
At procedure declaration, and at the beginning of each NAMED block or
compound statement, a count called NMLVL (name level) is incremented. Its
current value is stored in $VAL2 of every block and NAMED compound
statement. It is also stored in procedure blocks. It is decremented at
appropriate times.
When a block pointer is placed in BLKLIS (via BLKIDX QPDP), its left half
is 0 if the block has a name, -1 otherwise (depends on higher-LEVELed block
for name). A non-named block's NMLVL should be the same as that of the
next named block in the list.
Inner blocks appear in BLKLIS preceding outer ones. DDT (as it happens)
requires that symbols for inner blocks appear first. So the algorithm for
symbol allocation is:
1) Search from BLKLIS bottom to 1st named Block (index into SBITS2)
2) Put out Block name and level to .REL file
3) NMLVL of this block to TBITS2
4) For each BLKLIS entry from current backwards to bottom,
or until an entry is found whose NMLVL is lower (outer block)
that TBITS2, if the Block hasn't been handled (list entry 0),
include its symbols in this DDT block on the .REL file.
5) Search forwards for the next named block (index into SBITS2).
If one is found, go to step 2.
6) If some blocks were not handled, it is because the outer block of
this procedure was not named. Put out procedure name as block name,
and repeat step 3 once more to get the rest of the symbols.
7) Reset BLKIDX QPDP
⊗
;STEP 1,5 -- FORWARDS SEARCH LOOP
DOSYM: MOVEM B,SBITS2 ;B GETS CHANGED BY DOSYL1
DOSYML: MOVE B,SBITS2 ;GET QSTACK PDP FOR FORWARD SEARCH
QTAKE (BLKIDX) ;LOOK AT NEXT BLOCK
JRST DIDSYM ; HAVE LOOKED AT ALL, CHECK FOR REMAINING
AOS BLKCNT ;ADD ONE FOR EACH ONE GLIMPSED
MOVEM B,SBITS2 ;PROTECT THIS QPDP
JUMPLE A,DOSYML ;IF NOT NAMED, CONTINUE FORWARD SEARCH
MOVE LPSA,A
;STEP 2
PUSHJ P,BLBOUT ;ISSUE BLOCK NAME TO .REL FILE
;STEP 3
HRRZ TBITS2,$VAL2(LPSA) ;NMLVL (DDT LEVEL) OF THIS BLOCK
MOVE B,SBITS2 ;BLBOUT CHANGES, MAYBE
;STEP4 -- BACKWARDS SEARCH LOOP
DOSYL1: QBACK ;NONDESTRUCTIVE POP
JRST DOSYML ; HAVE ALL BLOCKS, RETURN TO FORWARD SEARCH
JUMPE A,DOSYL1 ;ALREADY DID THIS ONE
MOVE LPSA,A ;BELONGS HERE FOR NOSY ETC.
HRRZ TEMP,$VAL2(LPSA);NMLVL OF THIS BLOCK
CAMLE TBITS2,TEMP ;IF NEW LEVEL LOWER, DON'T INCLUDE IT,
JRST DOSYML ; RETURN TO FORWARD SEARCH
HLRZ TEMP,B ;GET CURRENT "QSTACK" POINTER
SETZM 1(TEMP) ;ZERO "POPPED" ENTRY
SOS BLKCNT ;SUBTRACT ONE FOR EACH ONE ALLOCATED
PUSH P,%TLINK(LPSA) ;
PUSH P,B
PUSHJ P,NOSY ;ALLOCATE SYMBOLS FOR THIS BLOCK
POP P,B
POP P,LPSA ;SEE IF HAD A SECOND SEMBLK
TLNN LPSA,-1 ;IF NOT
JRST DOSYL1 ;CONTINUE BACKWARDS SEARCH
HLRZ LPSA,LPSA ;WE DID
FREBLK ;DONE WITH IT NOW
JRST DOSYL1 ;CONTINUE BACKWARDS
;STEP 6 -- PUT OUT PROCNAME BLOCK IF NOT ALL GONE
DIDSYM: SKIPG BLKCNT ;DID WE SEE SOME WE DIDN'T ALLOCATE?
JRST DIDALL ; NO, ALL DONE
SETOM BLKCNT ;WON'T FAIL AGAIN
MOVE LPSA,TPROC ;USE PROCEDURE NAME AS OUTER BLOCK NAME
PUSHJ P,BLBOUT
MOVNI TBITS2,1 ;VERRRY LOW LEVEL
MOVE B,BLKIDX ;LOOK AT ALL POSSIBLE ENTRIES
JRST DOSYL1 ;GO ROUND ONCE MORE, GET THE REST
;STEP 7 -- CLEAN UP
DIDALL: QFLUSH (BLKIDX) ;RELEASE STORAGE, CLEAR QPDP
SKIPE SIMPSW ;NO PD FOR SIMPLE
JRST CRECHK ;
CRECHK:
TLNN FF,CREFSW ;IF ¬CREFFING, DONE.
POPJ P, ;DONE
MOVE LPSA,TPROC ;PROCEDURE NAME
CAIE LPSA,RESYM ;NOT THIS ONE;
JRST CREFBLOCK ;FOR BLOCK EXIT.
APOPJ: POPJ P,
NOSY: PUSHJ P,URGSTR ;IF ON STRING RING....
FREBLK ;DELETE THE BLOCK.
RIGHT ,%RVARB,APOPJ ;GO TO NEXT BLOCK.(OR POPJ)
SY2A: MOVE TBITS,$TBITS(LPSA)
TLNE FF,CREFSW ;IF CREFFING.
PUSHJ P,CREFDEF ;DEFINE THE SYMBOL.
TLNE TBITS,RES ;IF RESERVED WORD (NEW DEF),
JRST NOSY ; (VIA LET) , FORGET IT
TLNE TBITS,SBSCRP ;TURN OFF STRING IF ARRAY
TRZ TBITS,STRING
PUSHJ P,RAD50 ;MAKE SURE A SYMBOL NAME GETS MADE
IMSSS<
TRNE TBITS,ITEM ;IS IT AN ITEM AT IMSSS?
TLO A,400000 ;YES, TURN OFF PRINTOUT DDT
>;IMSSS
TRNE TBITS,ITEM
TLNE TBITS,FORMAL!SBSCRP!EXTRNL ;PUT OUT ITEM NUMBER IF
JRST NOITMS ;IT IS THERE.
HRRZ TEMP,$VAL2(LPSA) ;POINTER TO INTEGER.
MOVE B,$VAL(TEMP) ;ITEM NUMBER.
;; # # BY JRL (1-25-73)
CAMGE B,[20]
TLO A,400000 ;HALF KILL ITEM NO. < 20
;; # #
PUSHJ P,SCOUT0 ;NO RELOCATION.
JRST NOSY
NOITMS: HRRZ B,$ADR(LPSA) ;FIXUP
;;#KY# ALLOW GLOBAL INTERNAL SYMBOLS OUT (FIX 1 OF 2)
TRNE TBITS,GLOBL ;
TLNN TBITS,INTRNL ;
;;#KY# 1 OF 2
JUMPE B,NOSY1 ;NO SYMBOL
GLOC <
TRNE TBITS,GLOBL ;IF NOT GLOBAL
TRNE TBITS,ITEM ;OR IT ITEM, THEN
JRST REGSYM ;NOT POSSIBLY A GLOBAL TYPE.
HRLZ B,$ADR(LPSA) ;FIXUP CHAIN
HLR B,$VAL2(LPSA) ; AND THE GLOBAL NUMBER.
ADDI B,400013 ; GLOBAL DATA BASE.
HRRM B,$ADR(LPSA) ;FOR THE SYMBOL....
;;#KY# ! 2 OF 2
TLNE B,-1 ;ANY TO FIX UP?
PUSHJ P,FIXOUT ;FIXUP WITH NO RELOCATION.
PUSHJ P,SCOUT0 ;PUT OUT SYMBOL WITH NO RELOC.
JRST NOSY
REGSYM:
>;GLOC
;;#II#! 7-4-72 DCS DON'T LET DEFINES OUT!
TLNN TBITS,DEFINE
PUSHJ P,SOUT ;OUTPUT THE SYMBOL.
TRC TBITS,FORWRD!LABEL
TRCN TBITS,FORWRD!LABEL ;HAS A LABEL BEEN USED BUT NOT DEFINED?
ERR <UNUSED LABEL: >,3
NOSY1: TRNE TBITS,PROCED
JRST PPR ;PROCEDURE AND FRIENDS.
REC <
TRNE TBITS,PNTVAR ;
TRNN TBITS,SHORT ;A RECORD CLASS ID
JRST .+2 ;NO
TDC TBITS,[XWD SIMPLE,PROCED!PNTVAR!SHORT] ;NOW WILL DEALLOCATE
;SEMBLKS IN PROPER MANNER
>;REC
TLNN TBITS,DEFINE ;DELETE THE MACRO BODY ....
JRST CHARYZ ;CHECK ARRAYS.
PUSH P,LPSA
LEFT ,%TLINK,LPSERR
PUSHJ P,REMOPL ;UNLINK MACRO BODY.
POP P,LPSA
JRST NOSY ;ALL DONE
CHARYZ: TLNN TBITS,SBSCRP ;ARRAY?
JRST CHKTWO ; NO
PUSH P,LPSA
HRRZ B,$VAL(LPSA) ;ARRAY ADDRESS IF OWN ARRAY
MOVE A,RAD5. ;DOTTED SYMBOL NAME
TLZ A,740000 ;MAKE AN INTERNAL SYMBOL!
TLO A,100000 ;LIKE THIS
TLNE TBITS,OWN ;BUILT IN?
PUSHJ P,SCOUT ; YES, PUT OUT A SYMBOL
LEFT ,%TLINK,NOBBLK ;DELETE BNDBLK (SEE ARRAY)
FREBLK
NOBBLK: POP P,LPSA ; IF THERE IS ONE
CHKTWO: TLNE TBITS,INTRNL!EXTRNL ;IS THERE
TRNN TBITS,STRING ;A SECOND SYMBOL?
JRST NOSY ;NO -- DONE
MOVE A,RAD5. ;GET KLUDGED UP VERSION OF SYMBOL
HLRZ B,$ADR(LPSA) ;GET ADDRESS FOR 2D WORD
JUMPE B,NOSY ;AN EXTERNAL STRING COULD CAUSE THIS
PUSHJ P,SCOUT ;OUTPUT SYMBOL
JRST NOSY
PPR: TLNE TBITS,EXTRNL!MESSAGE ;DON'T MAKE THIS CHECK FOR EXTERNALS
JRST PPR1
TRNE TBITS,FORWRD ;CHECK FOR FORWARD NEVER DEFINED
ERR <FORWARD PROCEDURE NEVER DEFINED: >,3
PPR1: PUSH P,LPSA
LEFT ,%TLINK,LPSERR ;LPSA PNTS TO 2D PROC BLOCK
MOVE A,LPSA ;SAVE POINTER
LEFT (,%TLINK,PPR4) ;PTR TO FIRST PARAM OR NIL
PPR2:
COMMENT ⊗THIS COMMENT FLUSHES A POTENTIAL BUG
BUT STILL LEAVES EVIL AROUND, IN THE FORM OF WASTED SPACE
HRRZ B,$VAL2(LPSA) ;DOET THIS HAVE A DEFAULT VALUE
JUMPE B,PPRX ;NO
HRRZ C,$ADR(B) ;ZERO FIXUP ?
JUMPN C,PPRX ;NO?
EXCH B,LPSA ;
FREBLK ;GET RID OF IT
SKIPA LPSA,B ;LPSA ← FORMAL SEMBLK
⊗
PPRX: MOVE B,LPSA ;SAVE IT
;;#MC# ! NEED TO GET IT OFF STRING RING TOO RHT 4-20-73
PUSHJ P,URGSTR ;GET OFF THE STRING RING
FREBLK ;KILL IT
RIGHT (B,%RVARB,PPR4) ;GET NEXT
JRST PPR2
PPR4:
FREBLK (A) ;DELETE 2D PROC BLOCK
;THE FOLLOWING CODE HANDLES THE PROCEDURE DESCRIPTOR
MOVE LPSA,(P) ;PICK UP PROCEDURE
HRRZ A,$VAL(LPSA) ;PICK UP THE PD SEMBLK
JUMPE A,NOPD
TLNN TBITS,EXTRNL ;EXTERNAL?
JRST NOEXPD ;NO
SKIPGE C,$ADR(A) ;OUT ALREADY??
ERR <DRYROT AT NOSY --EXTERNAL PD >,1
TRNN C,-1 ;FIXUPS??
JRST PDFDON ;NO
PUSH P,B
PUSH P,A
HRLM C,PDFFHD ;REMEMBER FIXUP HEAD
PUSHJ P,RAD50 ;GET PROCEDURE RADIX50
TLC A,640000 ;CHANGE TYPE BITS
HLRM A,R5PD1 ;SAVE RADIX50 IN BLOCK
;;#KM# RHT ! 11-24-72 USE "A" INSTEAD OF "B"
HRLM A,R5PD2
MOVE B,PDPFBD ;POLISH FIXUP BLOCK DESC
PUSHJ P,FRBT ;FLUSH BN OUTPUT
PUSHJ P,GBOUT ;PUT OUT THE BLOCK
POP P,A
POP P,B
JRST PDFDON
NOEXPD:
;;#IV# RHT (9-22-72) IGNORE FORWARD PROCEDURES HERE
TRNE TBITS,FORWRD
JRST PDFDON
;;#IV#
PUSH P,A
PUSHJ P,RAD50 ;GET RADIX 50 SYMBOL
MOVE A,RAD5$ ;THE $ SYMBOL
TLZ A,740000
TLO A,100000 ;LOCAL PROCEDURE
HRRZ B,$VAL(LPSA)
SKIPL B,$ADR(B) ;THE ADDRESS
ERR <DRYROT AT NOSY -- NON EXTERNAL PROC>
PUSHJ P,SCOUT ;PUT PD SYMBOL OUT
POP P,A ;
PDFDON: HLRZ C,%TLINK(A) ;POINT AT PDA,,0 SEMBLK
FREBLK (A) ;FREE PD BLOCK
JUMPE C,NOPD ;FREE PDA,,0 BLOCK IF HAVE ONE
FREBLK (C)
NOPD:
POP P,LPSA
GLOC <
;;#JF# RHT (9-27-72) ! BE SURE MESSAGE BLOCK GETS RIGHT ADDR
HRRZ B,$ADR(LPSA) ;
CAIE B,0 ;IF FORWARD MESSAGE DESCRIP. NEVER DEFINED
TLNN TBITS,MESSAGE ;AND IS DEFINITELY A MESSAGE
JRST NOSY ; --
TLO FF,RELOC ;FIRST GOES THE WORD WHICH CHAINS LINKS.
HRRO A,PCNT
EXCH A,MESLNK ;MESSAGE LINK
PUSHJ P,CODOUT ;PUT IT OUT
HRL A,$PNAME(LPSA) ;STRING COUNT
HRR A,B ;ADDRESS OF PROCEDURE
TLO FF,RELOC ;AGAIN SINCE IF MESLNK WAS ZERO, OUR FRIEND
;CODOUT RESET RELOC.......
PUSHJ P,CODOUT ;XWD #CHARS,,PROD ADDRESS.
TLZ FF,RELOC
HRRZ C,$PNAME(LPSA) ;#CHARS AGAIN.
ADDI C,4 ;..
IDIVI C,=5
MES21: AOS B,$PNAME+1(LPSA);WE CAN HAPPILY DESTROY THE BYTE POINTER.
MOVE A,-1(B) ;FIRST WORD OF PNAMES.
PUSHJ P,CODOUT ;OUT IT GOES.
MOVE A,(B) ;NEXT WORD
CAIGE C,2 ;...
MOVEI A,0 ;NOT TWO WORDS LONG.
PUSHJ P,CODOUT
>;GLOC
JRST NOSY ;AND LOOP.
;LOADER BLOCK FOR POLISH FIXUP
LODBLK(,11,PDPFB,PDPFBD,5,,<XWD 001000,0>)
RELOC .-5
XWD 3,1 ;ADD , LITC
-1
R5PD1: XWD 2,0 ;OPDC ,, LH OF RAD50
R5PD2: XWD 0,-1 ;RH OF RAD50,,SHR
PDFFHD: XWD 0,0 ;DEST ,,0
DSCR BLBOUT
CAL PUSHJ
PAR LPSA is Semantics of Block with a name
DES outputs a Block name LOADER block via GBOUT. Saves RADIX50 for
name, and SHOUT makes sure that no two consecutive blocks output
with the same names. This can happen: PRODEDURE FINIS (..);
BEGIN "FINIS" ... two identical block names
cause havoc with DDT.
SID Uses most ACs except SBITS, PNT2 group
⊗
BLBOUT:
MOVE TBITS,$TBITS(LPSA) ;SEE IF IT IS A PROCEDURE OR NOT
HRRZ B,$VAL2(LPSA) ;LEVEL (DDT) OF THIS BLOCK
TRNN TBITS,PROCED ;IF PROCEDURE,
; GET LEVEL FROM DIFFERENT PLACE
JRST NOPRCC
HLRZ TEMP,%TLINK(LPSA)
HRRZ B,$VAL2(TEMP)
NOPRCC: PUSHJ P,RAD50 ;GET BLOCK NAME IN RADIX50
TLZ A,740000 ;CLEAR SYMBOL TYPE BITS
TLO A,140000 ;PUT IN THE RIGHT ONES
PUSHJ P,SCOUT ;PUT OUT BLOCK NAME
MOVEM A,LSTRAD ;SAVE RADIX50 FOR THE BLOCK NAME.
TRNE TBITS,PROCED
POPJ P,
MOVE A,RAD5.
TLZ A,740000 ;SHOULD BE BLOCK TYPE 10
TLO A,100000
HLRZ B,$VAL2(LPSA)
PPFF: JRST SCOUT ;MAKE LABEL FOR BLK OR CMPD STMT.
DSCR PDOUT
DES ROUTINE TO OUTPUT THE PROCEDURE DESCRIPTOR -- USED ONLY FOR DISPLAY SYSTEMS
PARM PROC SEMBLK ADDRESS IN PNT2
SID ALL ACCUMULATORS SAVED EXCEPT TEMP & LPSA
⊗
PDOUT: PUSH P,FF ;SAVE FF
PUSH P,A
PUSH P,B
PUSH P,C
PUSH P,SBITS2
PUSH P,TBITS
PUSH P,PNT
HRRZ PNT,$VAL(PNT2) ;PICK UP PD SEMBLK
JUMPE PNT,XPDOUT ;IF OUTER BLOCK, NOTHING GOES OUT
MOVEI A,0
TLZ FF,RELOC
PUSHJ P,CODOUT
MOVEI B,%PDLNK ;LINK THE PROC DESC
PUSHJ P,LNKOUT
HRRZ B,PCNT ;THE CURRENT ADDRESS
HRL B,$ADR(PNT) ;FIXUP REFERENCES TO PDA
HRROM B,$ADR(PNT) ;REMEMBER THE FACT THAT PDA IS RIGHT
TLNE B,-1 ;IF THERE WERE ANY
PUSHJ P,FBOUT ;DO IT
HRRZ A,$ADR(PNT2) ;ADDRESS OF PROC ENTRY
TLO FF,RELOC
PUSHJ P,CODOUT
HRRZ A,$PNAME(PNT2) ;LENGTH OF THE NAME
TLZ FF,RELOC
PUSHJ P,CODOUT ;PUT IT OUT
HRRZ B,PCNT
HRRM B,$PNAME+1(PNT) ;REMEMBER THIS SPOT
MOVE A,[POINT 7,0] ;BYTE PTR WORD FOR PNAME
PUSHJ P,CODOUT
MOVEI B,PROCB
MOVE A,$TBITS(PNT2)
TRNE A,ITEM!ITMVAR
TRO B,ITEMB
TLNE A,MPBIND ;MATCHING PROC?
TRO B,BINDB ;YEP
PUSHJ P,ITMTYP ;SIX BIT TYPE
;;# # ! USED TO BE LSH A,5 JFR 9-11-74
LSH A,=23 ;INTO ITS SPOT
TLO A,(B) ;OTHER BITS
;;%AA% A NEW FEATURE RHT -- SPROUT DEFAULTS 9-1-73
HLR A,$VAL(PNT2) ;ADD IN SPROUT DEFAULTS
PUSHJ P,CODOUT ;PUT OUT PROCEDURE TYPE
HLRZ B,%TLINK(PNT2) ;POINT AT 2ND PROC SEMBLK
MOVS A,$NPRMS(B) ;#SPARMS*2,,#APRMS +1 INTO AC A
PUSHJ P,CODOUT ;PUT IT OUT
HRL A,SSDIS ;+SS DISP
HRR A,ASDIS ;+AS DISP
PUSHJ P,CODOUT ;
LLPUT: HRLZ A,$SBITS(PNT2)
AND A,[XWD LLFLDM,0] ;LEX LEV
HRR A,$VAL2(PNT) ;LVI FIXUP
HRL B,PCNT
HLRM B,$VAL2(PNT)
TLO FF,RELOC
PUSHJ P,CODOUT
DLPUT: HRLZ A,CDLEV ;CURRENT DISPLAY LEVEL
HRR A,$VAL(PNT) ;PARAM INFO FIXUP
HRL B,PCNT ;
HLRM B,$VAL(PNT)
TLO FF,RELOC
PUSHJ P,CODOUT
HLRZ B,%TLINK(PNT) ;POINT AT [PDA,,0] SEMBLK
CAIN B,0 ;DO WE HAVE ONE
JRST PDAX0 ;NO
HRL B,$ADR(B)
HRR B,PCNT ;HERE IT IS
TLNE B,-1
PUSHJ P,FBOUT
PDAX0: HRLZ A,$ADR(PNT) ;PICK UP PDA INTO LH
PUSHJ P,CODLRL ;GO RELOCATE LH
HLRZ C,%TLINK(PNT2) ;LOOK AT 2ND PROC SEMBLK
HRRZ C,%SAVET(C) ;TO FIND PARENT PROC
MOVEI A,0 ;
JUMPE C,[ TLZ FF,RELOC ;IF THE TOP LEVEL (I.E. NO DADDY)
PUSHJ P,CODOUT ;PUT OUT THE 0
JRST PCPRD] ;GO ON TO NEXT THING
HRRZ C,$VAL(C) ;PD SEMBLK
HRRZ A,$ADR(C) ;EASIEST TO CHAIN BY SELF
HRR B,PCNT ;NEW CHAIN
HRRM B,$ADR(C)
HLL A,$ACNO(PNT) ;PCNT AT END OF MKSEMT
PPDA0: TLO FF,RELOC
PUSHJ P,CODLRL ;GO PUT IT OUT
;;%BI% ! (rht) used to be in $acno
PCPRD: MOVE A,$VAL2(PNT2) ;PCNT AT PRDEC,,EXIT(FIXED UP)
HRR A,$ACNO(PNT) ;PICK UP EXIT FROM PD SEMBLK
TLO FF,RELOC
PUSHJ P,CODLRL ;RELOC BOTH HALVES
HLRZ C,%TLINK(PNT2) ;SECOND PROC SEMBLK
HLRZ C,%SAVET(C) ;OLD TTOP
HRLZ A,PCNT ;
HLR A,$SBITS(C) ;FIXUP LVI REF TO PARENT BLOCK
HLLM A,$SBITS(C) ;FIXUP CONTINUED
HRRZS A ;SCRATCH THE OLD CRUFT
PUSHJ P,CODOUT ;PUT IT OUT
TLZ FF,RELOC
HLRZ LPSA,%TLINK(PNT2) ;LPSA← PTR TO 2ND PROC SEMBLK
HLRZ LPSA,%TLINK(LPSA) ;LPSA NOW PNTS TO FIRST PARA
JUMPE LPSA,DOLVIN ;THERE MAY NOT BE ANY
HRR B,PCNT
HRL B,$VAL(PNT) ;LOC OF START OF PROC PARAM INFO
PUSHJ P,FBOUT
PUSHJ P,TBCOUT ;GO PUT OUT INFO ON PARAMS
DOLVIN: PUSH P,PNT2
HRR B,PCNT
HRL B,$VAL2(PNT)
PUSHJ P,FBOUT
MOVE PNT,$SBITS(PNT2)
ANDI PNT,LLFLDM ;LEX LEVEL
RGC <
HRLZI A,RPCOD⊗=9(PNT) ;
LSH A,5 ;
SKIPE RECSW
TLOA A,RF
TLOA FF,RELOC ;NOT RECURSIVE MEANS RELOC
TLZ FF,RELOC ;RECSW MEANS DONT RELOC
SKIPN LPSA,RCTEMP ;THE RECORD TEMPS WE BUFFERED UP
JRST RCLV.2
RCLVLP: HRR A,$ADR(LPSA) ;THE CUPLRIT
PUSHJ P,CODOUT ;PUT IT OUT
HRRZ B,%TLINK(LPSA) ;REMEMBER THE NEXT
FREBLK ;KILL OFF THE BLOCK
SKIPE LPSA,B ;ITERATE
JRST RCLVLP
RCLV.1: HRLZI A,BLKCOD⊗=14
TLZ FF,RELOC
PUSHJ P,CODOUT
SETZM RCTEMP
RCLV.2:
>;RGC
SKIPE SBITS2,BLKIDX ;PICK UP
PUSHJ P,LVIOUT
POP P,PNT2
TLZ FF,RELOC
MOVEI A,0
PUSHJ P,CODOUT ;PUT OUT END OF LVI FLAG
MOVE PNT,$VAL(PNT2) ;PD SEMBLK AGAIN
HRL B,$PNAME+1(PNT) ;FIX UP THE STRING REFERENCE
HRR B,PCNT
PUSHJ P,FBOUT
HRRZ SBITS2,$PNAME(PNT2) ;LEN OF PNAME
TLZ FF,RELOC ;DO NOT RELOCATE
MOVE LPSA,$PNAME+1(PNT2) ;BYTE PTR FOR PNAME
TRDY: MOVE TEMP,[POINT 7,A]
MOVEI A,0
MOVEI B,5
TPNC: SOJL SBITS2,PNMDN
ILDB C,LPSA ;PICK UP CHAR
IDPB C,TEMP ;PUT IT DOWN
SOJG B,TPNC
PUSHJ P,CODOUT
JRST TRDY
PNMDN: CAIE B,5
PUSHJ P,CODOUT
XPDOUT: POP P,PNT ;RETURN
POP P,TBITS
POP P,SBITS2
POP P,C
POP P,B
POP P,A
POP P,FF
POPJ P,
↑TBCOUT: ;ROUTINE TO PUT OUT TYPE CODES FOR A RING OF THINGS
;TAKES LPSA= PTR TO FIRST SEMBLK
; USES LPSA,A,B
NPTB: MOVE A,$TBITS(LPSA) ;PICK IT UP
MOVEI B,
TRNN A,ITEM!ITMVAR ;ITEMISH ?
JRST NTITFP ;NO
TRO B,ITEMB ;YES
TLCE A,SBSCRP ;TEST THE ARY2 THING
TROA B,ARY2B ;
TLC A,SBSCRP ;
TLNE A,MPBIND ;BINDING ITEMVAR
TRO B,QUESB ;SAY SO
NTITFP: TLNE A,REFRNC ;REFERENCE??
TRO B,REFB ;THE REF BIT
TRNE A,PROCED ;PROCEDURE
TRO B,PROCB ;GET TYPE
PUSHJ P,ITMTYP ;
LSH A,5 ;LEFT 5 TO GET OUT OF FULL ADDR
TRO A,(B) ;THE OTHER BITS
HRLZ A,A ;THE OTHER HALF!
PUSHJ P,CODOUT ;PUT IT OUT
RIGHT ,%RVARB,CPOPJ
JRST NPTB ;GO DO NEXT ONE
;ROUTINE TO PUT OUT LOCAL VAR INFO -- USED BY DIS
;PARAMS -- BLOCK QPDP IN SBITS2,, LEX LEV IN PNT
LVIOUT: PUSH P,[-1] ;CLEVER FLAG TO CATCH BIG PARENT
LVIO.1: MOVE B,SBITS2
QBACK
JRST LVIEXT ;ALL DONE
MOVEM B,SBITS2
MOVE PNT2,A ;GET HIS NAME
LDB PNT,[POINT LLFLDL,$SBITS(PNT2),=35]
HRRZ B,PCNT
HLL B,$SBITS(PNT2)
TLNE B,-1
PUSHJ P,FBOUT ;FIXUP REFS FOR THIS BLOCK'S INFO, IF ANY
HRLM B,$SBITS(PNT2) ;REMEMBER MY SPOT
HLRZ LPSA,%TLINK(PNT2) ;SECOND PROC SEMBLK
JUMPE LPSA,LIT.1 ;NONE
SKIPN $ACNO(LPSA) ;THE QPDP FOR CLEANUPS
JRST LIT.1 ;NONE
QBEGIN (<$ACNO(LPSA)>) ;GET INITIAL QPDP
LIT.0: QTAKE ;TAKE ONE
JRST LIT.X ;DONE
MOVE TBITS,$TBITS(A) ;GET TYPE
MOVE C,A ;
HRRZ A,$ADR(C) ;ADDRESS
TDNN TBITS,[XWD EXTRNL,FORWRD+INPROG] ;NEED FIXUP?
JRST LIT.01 ;NO
HRL C,PCNT ;YES
HLRM C,$ADR(C) ;
LIT.01: HRLI A,CLNCOD⊗=14 ;TYPE IS CLEANUP
DPB PNT,[ POINT =9,A,=12] ;LEX LEV
TLO FF,RELOC ;RELOC
PUSHJ P,CODOUT ;
JRST LIT.0 ;GET NEXT
LIT.X: QFLUSH
LIT.1: MOVE LPSA,PNT2
LITER: RIGHT ,%RVARB,EBK ;GO DOWN VARB RING
MOVE TBITS,$TBITS(LPSA) ;PICK UP TYPE BITS
;;#IT# RHT 8-4-72 ! KEEP OUT EXTERNALS
;;#IZ# RHT 9-25-72 ! ALSO KEEP OUT GLOBALS
TDNE TBITS,[XWD EXTRNL!OWN,GLOBL!PROCED];OWN STUFF NEVER GOES,
; ALSO NO PROCS OR EXTERNALS
JRST LITER
TLNE TBITS,SBSCRP
JRST ARYINF
;;# # DCS 5-3-72 SETS, BUT NOT SET ITEMS!!
TRNE TBITS,ITMVAR!ITEM ;CHECK IT OUT -- DCS
JRST LITER ;LOOP
;;# # 5-3
;;%BI%
REC <
TRNE TBITS,PNTVAR ;PERHAPS A RECORDISH THING
JRST RECINF ;WE SHALL SEE
>;REC
;;%BI%
TRNE TBITS,SET ;SET??
JRST SETINF
TRNE TBITS,INTEGR ;TEST FOR THE FOREACH KLUGE (FLOATING INTEGER)
TRNN TBITS,FLOTNG
JRST LITER ;LOOP
FRCINF: MOVEI B,FRCCOD ;FOREACH CODE
JRST PUTCI
REC <
;;%BI%
RECINF: TRNE TBITS,SHORT ;A CLASSID?
JRST LITER ;YES
MOVEI B,RPCOD ;A REC PTR
JRST PUTCI ;
;;%BI%
>;REC
ARYINF: TLNE TBITS,BILTIN ;BUILT IN
JRST LITER ;YES,DONT BOTHER
MOVEI B,AACOD ;ARITH CODE
;;#QJ# !2 RHT IF AN ITEMVAR ARRAY, BETTER DEALOCATE AS ARITHMETIC
TRNE TBITS,ITEM!ITMVAR
JRST PUTCI ;SO DONT DEALOCATE BASED ON DATUM TYPE
TRNE TBITS,STRING ;MAYBE IT WAS A STRING ARRAY
MOVEI B,SACOD
TRNE TBITS,SET ;OR A LEAPISH THING
MOVEI B,LACOD
REC <
TRNE TBITS,PNTVAR ;OR PERHAPS A RECORD ARRAY
MOVEI B,RPACOD ;
>;REC
JRST PUTCI
;;# # RHT 8-1-72 KILL SET
SETINF: TLNN TBITS,SAFE ;CHECK IF KILL SET
JRST SETI.1 ;NO
TRNN TBITS,INTEGR ;BE SURE
ERR <DRYROT AT LVIOUT>
MOVEI B,KLCOD
JRST PUTCI
;;# # RHT 8-1-72
;;#RJ# USED ONLY TO PUT OUT IF RECURSIVE ! RHT 2-21-74
SETI.1: ; USED TO SKIPN RECSW HERE
MOVEI B,CTXCOD ;CONTEXT?
TRNE TBITS,FLOTNG ;CHECK
JRST PUTCI
MOVEI B,SETCOD
PUTCI: MOVEI A,0
SKIPE RECSW ;IS THIS FORB RECURSIVE??
HRLZI A,RF
DPB B,[POINT 4,A,3]
DPB PNT,[POINT =9,A,=12]
TLO FF,RELOC
SKIPE RECSW
TLZ FF,RELOC
HRR A,$ADR(LPSA)
TRNE A,-1 ;DID IT GET USED?? - IF SO MUST BE NON ZERO FOR
;EITHER CORE OR STACK (SINCE (F) IS DYN LINK)
PUSHJ P,CODOUT
JRST LITER
EBK: HRLZ A,PNT
LSH A,5 ;PUT LEX LEV IN RIGHT SPOT
MOVEI B,BLKCOD ;SAY IT IS A BLOCK
DPB B,[POINT 4,A,3]
AOSN (P) ;IS THIS THE OUTER BLK FOR THIS PD
JRST .+4 ;YES LINK UP IS ZERO
HLRZ B,$ADR(PNT2) ;
HLR A,$SBITS(B) ;RH OF A ←← PARENT'S LVI AREA
TLOA FF,RELOC ;
TLZ FF,RELOC ;NEVER RELOC 0
PUSHJ P,CODOUT ;PUT OUT FLAG WORD
JRST LVIO.1 ;GO GET NEXT BLOCK
LVIEXT: SUB P,[XWD 2,2] ;FLUSH THE FLAG
JRST @1(P) ;RETURN
;; %AA% -- SDFLTS
↑SDFLTS:
MOVE PNT,GENLEF+1;
PUSHJ P,GETAD; BETTER HAVE AN INTEGER CONSTANT
TRNN TBITS,INTEGR
ERR <YOU NEED AN INTEGER CONSTANT HERE>,1,CPOPJ
MOVE A,$VAL(PNT)
LSH A,-4 ;THE VALUE SHIFTED TO GET RID OF CONTROL OPTS
SKIPE SIMPSW ;MAY NOT BE SIMPLE
ERR <YOU CANNOT DO THIS INSIDE A SIMPLE PROCEDURE>,1,CPOPJ
MOVE PNT2,TPROC ;THE CURRENT PROCEDURE
HRLM A,$VAL(PNT2) ;SAVE IT AWAY
;;#OB# RHT ! 10-31-73 NEED TO SETZM BITS
JRST CLRSET ;DONE
COMMENT ⊗Allo -- Allocate One Type of Symbol
ALLO looks at each symbol and outputs its core locations, etc.
It also outputs fixups, and saves the final core address in
$ADR so that the symbol-outputter can find it.
⊗
ALLO: MOVEI PNT2,0 ;COUNT OF LOCALS ALLOCATED.
SKIPN SBITS2,BLKIDX ;GET QPDP FOR BLOCK QSTACK
JRST CPOPJ ; NOTHING TO ALLOCATE
ITE: MOVE B,SBITS2 ;GET QPDP TO PARAM POSITION
QBACK ;NON-DESTRUCTIVE QPOP
JRST [HRR A,FIRSYM ;SET UP ALIMS-TYPE WORD
HRL A,LSTSYM
POPJ P,] ;DONE
MOVEM B,SBITS2 ;SAVE UPDATED QPDP
MOVE LPSA,A
ITER: RIGHT ,%RVARB,ITE ;GO DOWN LIST
MOVE TBITS,$TBITS(LPSA) ;TYPE BITS.
REC <
TRNE TBITS,PNTVAR
TRNN TBITS,SHORT ;SHORT PNTVAR IS CLASS ID, NEVER GOES
JRST .+2
TRZ TBITS,PNTVAR!SHORT
>;REC
TRNE TBITS,SET ;IF A SET DO NOT ALLOCATE AS ARITH TOO
TRZ TBITS,FLOTNG!INTEGR
TLNE TBITS,SBSCRP ;DO NOT ALLOCATE AS BOTH ARRAY AND INTEGER!!!
NOREC <
TRZ TBITS,STRING!INTEGR!FLOTNG!ITMVAR!ITEM!SET!LSTBIT!LPARRAY!SHORT
>;NOREC
REC <
TRZ TBITS,STRING!INTEGR!FLOTNG!ITMVAR!ITEM!SET!LSTBIT!LPARRAY!SHORT!PNTVAR
>;REC
TRNE TBITS,ITEM!ITMVAR
NOREC <
TRZ TBITS,STRING!INTEGR!FLOTNG!SET!LSTBIT
>;NOREC
REC <
TRZ TBITS,STRING!INTEGR!FLOTNG!SET!LSTBIT!PNTVAR
>;REC
TRNN TBITS,PROCED!LABEL ;NEVER SPACE FOR THESE.
TDNN TBITS,TBITS2 ;USE THE MASK.
JRST ITER ;NO MATCH -- GO FARTHER
ALOWDS:
TDNE TBITS,[XWD EXTRNL!DEFINE,GLOBL] ;PUT OUT NO CODE
; OR FIXUPS FOR EXTERNALS
JRST ITER
TLNE TBITS,SBSCRP ;ALWAYS ALLOCATE ARRAYS
JRST ANYWAY
SKIPN B,$ADR(LPSA) ;IF $ADR IS 0 AND SYMBOL IS NOT
TLNN TBITS,INTRNL ; INTERNAL, DON'T PUT OUT CODE OR FIXUPS
JUMPE B,ITER
ANYWAY:
SKIPE RECSW ;IF NOT RECURSIVE
TDNE TBITS,[XWD OWN,ITEM] ;OR VAR IS OWN, ITEM OR THE LIKE
JRST ALCV ;IT GETS INTO CORE
AOS B,CSPOS ;USE A STACK LOCN
TLNN FF,ALLOCT ;ALLOCATING?
JRST [TRNE TBITS,STRING ;NO-- IS IT A STRING?
AOS CSPOS ;YES
JRST ITER]
HRL B,$ADR(LPSA) ;FIRST FIXUP
HRRM B,$ADR(LPSA) ;SAVE ITS SACK INC
TLNE B,-1 ;MIGHT BE UNUSED
PUSHJ P,FIXOUT ;NO RELOC FOR FIXED UP VALUE
TRNN TBITS,STRING ;STRING????
JRST ITER ;NO -- DONE WITH THIS
AOS B,CSPOS ;BUMP STACK DISPL
HLL B,$ADR(LPSA) ;SECOND WORD FIXUP CHAIN
HRLM B,$ADR(LPSA) ;SAVE IT
TLNE B,-1 ;USED?
PUSHJ P,FIXOUT ;YES
JRST ITER ;AT LAST
ALCV:
MOVEM LPSA,LSTSYM ;LAST SYMBOL
AOS PNT2 ;INCREMENT COUNT.
SKIPN FIRSYM
MOVEM LPSA,FIRSYM ;RECORD FIRST SYMBOL ONCE!!
TLNN FF,ALLOCT ;ACTUALLY ALLOCATE?
JRST ITER ;NO -- LOOP
HRLZ B,$ADR(LPSA) ;FIRST FIXUP
HRR B,PCNT
HRRM B,$ADR(LPSA) ;SAVE THE PCNT FOR SOUT TO FIND.
TLNE B,-1 ;IN CASE A STRING WHICH ONLY USES SECOND WD.
PUSHJ P,FBOUT ;OUTPUT THE FIXUP
; BUG TRAP -- $VAL SHOULD GENERALLY BE 0 THRU HERE
SKIPE A,$VAL(LPSA) ;VALUE WORD
TRNE TBITS,ITEM ;EXCEPT ITEMS.........
JRST NVL ; IT IS ZERO
TLNN TBITS,SBSCRP ;CAN BE NON-ZERO IF ARRAY
ERR <DRYROT -- ALLO>,1
NVL:
TLZ FF,RELOC
TLNE TBITS,SBSCRP ;WANT RELOCATABLE IF ARRAY
TLO FF,RELOC ; UNLESS IT IS ZERO
PUSHJ P,CODOUT ;OUTPUT A WORD FOR IT!
RGC <
TLNN TBITS,SBSCRP ;OWN RPTR ARRAYS HANDLED ELSEWHERE
TLNN TBITS,OWN!BILTIN ;OWN??
JRST NVL.1 ;NOPE
TRNE TBITS,PNTVAR ;RECORD PNTR??
TRNE TBITS,ITEM!ITMVAR ;WELL
JRST NVL.1 ;NOPE
HRLO A,$ADR(LPSA) ;-1,,ADDRESS
PUSH P,LPSA ;SAVE IT FROM HARM
QPUSH (RBSTK) ;REMEMBER IT FOR LATER
POP P,LPSA
NVL.1:
>;RGC
TLZ FF,RELOC ;MAKE SURE IT'S OFF
TRNN TBITS,STRING ;DO WE WANT STILL ANOTHER WORD?
JRST ITER ;NO -- LOOP
HLLZ B,$ADR(LPSA) ;SECOND FIXUP
HRR B,PCNT
HRLM B,$ADR(LPSA) ;SAVE THIS FOR 2D SYMBOL IF ANY
TLNE B,-1 ;IN CASE NOT USED.
PUSHJ P,FBOUT ;OUTPUT FIXUP
MOVEI A,0
PUSHJ P,CODOUT ;AND A WORD OF STORAGE.
JRST ITER ;LOOP
;ROUTINE TO ALLOCATE SPACE FOR TEMP CELLS AND TO OUTPUT
;FIXUPS.
TMPALO: SETZM PNT2 ;COUNT
HRRZ LPSA,TTEMP
JUMPE LPSA,CPOPJ
RGC <
TLNN FF,ALLOCT ;ONLY WORK HARD IF ACTUALLY ALLOCATING
JRST TMPAL
MOVEI PNT,0 ;USE THIS TO HOLD THE CHAIN
RCTMLP: MOVE SBITS,$SBITS(LPSA)
SETZM %TLINK(LPSA) ;SINCE NON-ZERO IS A MARK
TLNN SBITS,CORTMP
JRST NXRCTM
TLNN SBITS,INDXED ;CHECK ALSO SUBFIELD INDXED CORTMP
JRST RCTM.1 ;NOT ONE OF THOSE
HRRZ B,$VAL2(LPSA) ;WELL ??
JUMPE B,NXRCTM ;NOT ONE OF THOSE
JRST RCTM.2 ;YES IT IS
RCTM.1: MOVE B,$TBITS(LPSA)
TRNE B,PNTVAR ;A RECORD VBL
TRNE B,ITEM!ITMVAR ;BUT NOT AN ITEMISH THING
JRST NXRCTM ;NOPE
RCTM.2: HRROM PNT,%TLINK(LPSA);MARK IT
MOVE PNT,LPSA ;& REMEMBER CHAIN
NXRCTM: HRRZ LPSA,%RVARB(LPSA)
JUMPN LPSA,RCTMLP
HRRZM PNT,RCTEMP ;REMEMBER WHICH TEMPS WERE RECORD VALUES
HRRZ LPSA,TTEMP ;BACK IN BUSINESS
>;RGC
TMPAL: MOVE SBITS,$SBITS(LPSA) ;S BITS.
TLNN SBITS,CORTMP ;A CORE TEMP?
JRST TMNXT ;NO
MOVEM LPSA,LSTSYM ;SAVE
SKIPN FIRSYM ;NO ARITH VARIABLES?
MOVEM LPSA,FIRSYM ; THAT'S RIGHT, THIS TEMP IS FIRST
MOVEI TEMP,INTEGR ;MIGHT BE INDXED STRING TEMP LEFT OVER,
MOVEM TEMP,$TBITS(LPSA) ;THIS IS EASIEST WAY TO AVOID CONFUSION
;(PRUP CHECKS STRING, DOES FXTWO, WE DON'T
; WANT THAT HERE)
TLZ SBITS,INDXED!FIXARR ;DO SOME THINGS TO SBITS TOO
TLZE SBITS,INAC!PTRAC!STTEMP ;ONLY REMAINING USE IS
ERR <DRYROT -- TMPALL>,1 ; FOR REC. PROC BLT CODE
MOVEM SBITS,$SBITS(LPSA) ;(MORE HONESTY)
AOS PNT2
SKIPN RECSW ;IF NOT RECURSIVE
JRST ALCTMP ;THEY GO TO CORE
AOS B,CSPOS ;BUMP THE STACK OFFSET
TLNN FF,ALLOCT ;ACTUALLY ALLOCATE?
JRST TMNXT ;NO
HRL B,$ADR(LPSA) ;PICK UP FIXUP CHAIN
RGC <
HRRZM B,$ADR(LPSA) ;REMEMBER THE SURE ENOUGH VALUE
>;RGC
PUSHJ P,FIXOUT ;FIXUP
JRST TMNXT
ALCTMP:
TLNN FF,ALLOCT ;ACTUALLY ALLOCATE?
JRST TMNXT ;NO
HRR B,PCNT
HRL B,$ADR(LPSA)
RGC <
HRRZM B,$ADR(LPSA) ;REMEMBER THE SURE ENOUGH VALUE
>;RGC
PUSHJ P,FBOUT ;FIXUP
; PUT OUT A "TEMPXX" SYMBOL
MOVE A,$PNAME(LPSA) ;ID NO FOR THIS TEMP
IDIVI A,=10 ;TENS IN A, ONES IN B
ADDI A,1
IMULI A,50 ;RADIX50 FOR TENS
ADDI B,1 ;RADIX50 FOR ONES
ADD A,[<XWD 100000,0>+(<RADIX50 0,TEMP>*50*50)]
ADD A,B ;A HAS RADIX50 FOR "TEMPXX"
HRRZ B,PCNT
PUSHJ P,SCOUT ;WRITE A SYMBOL
MOVEI A,0
PUSHJ P,CODOUT
TMNXT: HLRZ PNT,%RVARB(LPSA) ;GET NEXT ONE
RGC <
SKIPN %TLINK(LPSA) ;ALSO DON'T KILL IF IT WAS A RECORD TEMP
;PDOUT WILL HACK THINGS
>;RGC
TLNN FF,ALLOCT
JRST TMNN
FREBLK ;RELEASE THE SYMBOL TABLE BLOCK
TMNN: MOVE LPSA,PNT ;COPY IT BACK.
JUMPN LPSA,TMPAL ;LOOP
POPJ P,
↑LNKMAK: ; PUT OUT STRING LINK BLOCK, IF NECESSARY
SKIPN TEMP,SLOCALS
JRST SETLNQ
LSH TEMP,-1 ;NUMBER OF STRINGS
HRLZ A,TEMP ;WORD WILL BE #STRINGS,,ADDR OF FIRST
HRRZ LPSA,SLIMS ;SEMANTICS OF FIRST
HRL C,$ADR(LPSA) ;ADDR OF FIRST
TRO A,NOUSAC+USADDR
PUSHJ P,EMITER ;PUT OUT DESCRIPTOR WORD
EMIT (<NOADDR+NOUSAC>) ;LINKAGE WORD -- PUT OUT ZERO
MOVEI B,1 ;STRING LINK.
PUSHJ P,LNKOUT ;THEN A LINKAGE CALL TO LOADER REFERENCING IT
SETLNQ: SKIPN A,LLOCAL
POPJ P, ;NO SETS TO LINK UP EITHER.
MOVNS A ;A WILL BE - # OF SETS,,ADR OF FIRST.
HRRZ LPSA,LLIMS ;SEMANTICS OF FIRST ONE.
HRL C,$ADR(LPSA) ;ADDRESS OF FIRST ONE.
HRRI A,NOUSAC!USADDR
PUSHJ P,EMITER ;PUT IT OUT.
EMIT (NOADDR!NOUSAC) ;FOR THE LINK.
MOVEI B,3 ;SET LINK NUMBER
JRST LNKOUT
SNTP: POPJ P,
COMMENT ⊗REQINI -- USER REQUIRED INITIALIZTIONS⊗
ZERODATA()
INIPDP: 0 ;QSTACK POINTER FOR INITIALIZATIONS
INIMAN: 0 ;FLAG IF INMAIN HAS BEEN CALLED
ENDDATA
DSCR REQINI,REQIN1,REQIN2
CAL PUSHJ
PARM REQINI -- TAKES PROC SEMBLK FROM GENLEF+1
REQIN1 -- PROC SEMBLK IN PNT
REQIN2 -- INITIALIZATION WORD IN A
-- PHASE #,,LOC TO BE PUSHJ'ED TO
RQINIX -- TAKES PROC SEMBLK IN GENLEF+3, PHASE IN GENLEF+1
REQIXX -- PROC SEMBLK IN PNT, PHASE IN SBITS2
DES PUSHES AN INITIALIZATION REQUEST ONTO QSTACK INIPDP. DONES
WILL PUT OUT THE CONTENTS OF THIS QSTACK AS THE INITIALIZATION
REQUEST BLOCK.
⊗
;;%AM% (1 OF 2) ALLOW USER TO SPECIFY PHASES
↑RQINIX: MOVE PNT2,GENLEF+1 ;PHASE NUMBER
MOVE PNT,GENLEF+3 ;PROCEDURE
MOVE TBITS2,$TBITS(PNT2);
TDNN TBITS2,[XWD CNST,INTEGR]; MUST BE AN INTEGER
JRST [ERR <PHASE NUMBER MUST BE INTEGER CONST>,1
JRST REQIN1
]
SKIPGE SBITS2,$VAL(PNT2);GET THE VALUE
JRST [ ERR <PHASE NUMBER MUST BE GEQ 0>,1
MOVEI SBITS2,0
JRST REQIXX
]
CAIL SBITS2,USRPHS ;MUST BE LESS
JRST [
ERR <PHASE NUMBER TOO BIG>,1
MOVEI SBITS2,USRPHS-1
JRST REQIXX
]
JRST REQIXX
↑REQINI:MOVE PNT,GENLEF+1 ;GET PROCEDURE
↑REQIN1:MOVEI SBITS2,1 ;THE LOWEST PHASE NUMBER+1
↑REQIXX:HLRZ PNT2,%TLINK(PNT);2ND BLOCK
;;%AM%
;;#QK# RHT OWN PROCS ARE SPECIAL
PUSHJ P,GETAD
TLNE TBITS,OWN ;RUNTIME ROUTINE??
JRST [ MOVE A,$ACNO(PNT) ;BYTE WORD
TLNE A,770000 ;ZERO BYTE HERE MEANS NO PARAMS
ERR <THIS PROCEDURE HAS PARAMETERS>,1
JRST EXTCSE ;TREAT AS AN EXTERNAL
]
;;#QK#
;;#JH# ! RHT 9-29-72 TYPO ERROR
HRLZI A,1 ;
CAME A,$NPRMS(PNT2) ;ANY PAPAMS
ERR <THIS PROCEDURE HAS PARAMETERS>,1
TLNN TBITS,FORWRD!EXTRNL ;IF ONE OF THESE, HARDER
JRST ESYCS
;;#QK# !
EXTCSE: HRRZ C,PCNT
HRLI C,2(C)
EMIT <JRST NOUSAC!USADDR> ;JRST .+2
HRRZ A,PCNT
HRLI A,400000
QPUSH (INIPDP) ;REMEMBER THIS SPOT
EMIT <JRST NOUSAC> ;CALL THE PROCEDURE
POPJ P,
ESYCS: HRRZ A,$ADR(PNT)
;;%AM% (2 OF 2) !
HRLI A,400000(SBITS2) ;PHASE NO
REQIN2: QPUSH (INIPDP) ;REMEMBER THE ROUTINE ADDRESS
POPJ P,
COMMENT ⊗ INMAIN - REQUEST INITIALIZATION FOR MAINPR IF NOT ALREADY DONE ⊗
↑INMAIN: SKIPE INIMAN ;ALREADY REQUESTED?
POPJ P, ;YES
SETOM INIMAN ;REQUESTED NOW
HRRZ C,PCNT
HRLI C,2(C) ;FOR JRST .+2
EMIT <JRST NOUSAC!USADDR>
HRL C,PCNT
EXCH C,LIBTAB+RMAINPR ;LIBRARY ENTRY FOR MAINPR
EMIT <JRST NOUSAC!USADDR>
HRR A,PCNT
SUBI A,1
HRLI A,1 ;PHASE 1
JRST REQIN2
SUBTTL DONES -- Storage Allocation Routines -- end of program
DSCR DONES
PRO DONES
DES This is the DONE code. It takes care of any allocation that
must be left until the end, allocates constants,etc.
The order of operations is:
1. Allocate space for any remaining variables, temps, etc.
1aa. Put out block of counters if /K switch is specified.
1aaa. Put out initialization link.
1a. Put out LEAP printnames if any.
2. Allocate space for constants,string constants, and address constants.
3. Output external requests for built-in procedures.
4. Output external requests for run-time (XCALL) routines.
5. Put out rqsts for other programs to be loaded, libraries
to be searched
6. Finish all binary output, and write an end block.
7. Put out the space allocation information block. This is examined
at run time to know how much space need be allocated for various
purposes (strings, leap, array push-down, etc.).
SEE ALOT for variable-allocation code
⊗
;1
↑DONES: PUSHJ P,ALLSTO ;STORE EVERYONE
;;%BT% RHT MAKE PD LOOK BETTER
MOVE LPSA,TPROC ;GET CORRECT LOC FOR JRST EXIT
MOVEI TEMP,3 ;PCNT AT START OF PROC
HRRM TEMP,$ADR(LPSA) ;SO PD IS CORRECT
MOVE TEMP,PCNT
HRRM TEMP,$ACNO(LPSA)
;;%BT% ↑
;;%AL% RHT ! TREAT 12 RIGHT
EMIT <MOVE RF,NOUSAC+NOADDR(RF)>
MOVE A,[XWD 3,3]
PUSHJ P,CREINT
EMIT <SUB P,NOUSAC>
EMIT (<POPJ RP,NOUSAC+NOADDR>) ;RETURN
TLO FF,ALLOCT ;THIS TIME WE DO THINGS RIGHT OFF
PUSHJ P,ALOT
SKIPE ADRTAB ;MUST BE EXHAUSTED AT THIS POINT
ERR <DRYROT -- DONES>,1
;;%BV% -- BY NOW HAVE PUT OUT PD, SO PDA HAS CORRECT PCNT
MOVE TEMP,TPROC ;
MOVE TEMP,$VAL(TEMP) ;GET PD SEMBLK
MOVE TEMP,$ADR(TEMP) ;LOCN OF PDA
HRRM TEMP,OBPDA ;PUT IT AWAY
;;%BV% ↑
BAIL<
SKIPG BAILON
JRST NBAI01
SETZ SBITS,
PUSHJ P,VALOUT ;FLAG END OF TABLE
HRROI SBITS,-1
PUSHJ P,VALOUT ;FLAG END OF FILE
TENX< PUSHJ P,VALOU1 ;DUMP LAST BUFFER
>;TENX
NOTENX< OUTPUT SM1, ;DUMP LAST BUFFER
>;NOTENX
NBAI01:
>;BAIL
REN <
PUSHJ P,LOSET ;DATA TO DATA SEGMENT
>;REN
COMMENT ⊗
If the /K switch was specified, we are now ready to alocate
space for the counters and put out the small data block used
by the runtime routines K.ZERO and K.OUT. The block is linked to
other such blocks via the loader LINK feature, using link
number 5. There will be multiple counter blocks only in the
case of multiple compilations. If there are no counters
inserted, then nothing is put out. The symbolic name
.KOUNT is given to the location of the first counter. The
routine K.OUT needs a file name to write the counters out to
after execution. The filename is set to the name of the listing
file. (they will have different extensions.) The generated
code will look as follows:
--------------------------
| SIXBIT /FILNAM/ |
--------------------------
| LINK to other blocks |
--------------------------
| IOWD 4,.-2 |
--------------------------
| IOWD n,.KOUNT |
--------------------------
| 0 |
--------------------------
.KOUNT: | 1st counter |
--------------------------
| . . . |
| . . . |
--------------------------
| nth counter |
--------------------------
⊗
SKIPE KOUNT ;ARE WE INSERTING COUNTERS
SKIPN KCOUNT ;AND ARE THERE ANY
JRST NOK3 ;NO ON ONE OF THE ABOVE
NOTENX <
MOVEI TBITS2,LSTCDB ;GET FILE NAME
MOVE A,CFIL(TBITS2)
>;NOTENX
TENX <;WE WANT THE SIXBIT NAME OF THE LST FILE IN AC A
ZERODATA
LISFLN: BLOCK 11
ENDDATA
PUSH P,B
PUSH P,C
PUSH P,D
HRROI A,LISFLN
HRRZ B,LISJFN ;SET UP IN CC
MOVSI C,002000 ;PRINT NAME ONLY
JSYS JFNS ;GET THE NAME
MOVEI C,6
SETZ A, ;ACCUMULATE SIXBIT HERE
MOVE B,[POINT 7,LISFLN,-1]
SIXLUP: ILDB D,B ;GET A BYTE
SKIPE D
SUBI D,40 ;CONVERT TO SIXBIT
LSH A,=6 ;MOVE OVER
ADD A,D ;ADD IN
SOJG C,SIXLUP
POP P,D
POP P,C
POP P,B
>;TENX
TLZ FF,RELOC ;DON'T RELOCATE IT
PUSHJ P,CODOUT ;WRITE IT
MOVEI A,0
PUSHJ P,CODOUT ;PUT OUT A ZERO WORD
MOVEI B,5 ;LINK IT INTO CHAIN 5
PUSHJ P,LNKOUT
MOVE C,PCNT
MOVSI C,-3(C)
EMIT (<XWD -4,NOUSAC!USADDR>) ;IOWD 4,.-2
MOVN A,KCOUNT
HRLZ A,A ;-COUNT
HRR A,PCNT ;.KOUNT-2
ADDI A,1 ; IOWD N,.KOUNT
TLO FF,RELOC ;RELOC PLEASE
PUSHJ P,CODOUT
MOVEI A,0 ;ANOTHER 0
PUSHJ P,CODOUT
PUSHJ P,FRBT ;FORCE OUT CODE BLOCK
HRRZ B,PCNT
MOVE A,[RADIX50 10,.KOUNT] ;DEFINE SYMBOLIC NAME
PUSHJ P,SCOUT ;FOR THE COUNTERS
MOVE A,KCOUNT
ADDM A,PCNT ;LEAVE SPACE FOR THEM
COMMENT ⊗ Now we fix up all counters addresses in
the AOS instructions that have already been output.
⊗
MOVE B,PCNT ;POINT JUST PAST THE COUNTERS
ISK1: MOVEI B,-1(B) ;MOVE POINTER BACK ONE
QPOP (KPDP) ;GET ADDR OF AN AOS
JUMPL A,NOK3 ;THAT'S ALL
HRL B,A ;PREPARE B FOR FBOUT
PUSHJ P,FBOUT ;FIXUP
JRST ISK1 ;ONE MORE TIME
NOK3:
BAIL< ;PUT OUT FILE NAME AND RELOCATION CONSTS.
SKIPG BAILON
JRST NBAI02
SETZ A,
TLZ FF,RELOC ;NO RELOC
PUSHJ P,CODOUT ;PUT OUT ZERO WORD
MOVEI B,%BALNK
PUSHJ P,LNKOUT ;LINK IT TO BAIL CHAIN
TLO FF,RELOC ;RELOC
;;#%%# BY JFR 11-13-74 MAKE THIS XWD 1<CODE>,1<DATA> IN ALL CASES
MOVE A,[XWD 1,1] ; A RELOCATABLE 1
REN<
SKIPE HISW ;TWO SEG PROG?
HRLI A,400001 ;YES
;;#%%# ↑
>;REN
PUSHJ P,CODLRL ;RELOCATE BOTH HALVES
TLZ FF,RELOC ;NO RELOC
NOTENX<
MOVEI A,1 ;ONE WORD FOR SIXBIT FILE NAME
PUSHJ P,CODOUT
MOVEI TBITS2,SM1CDB
MOVE A,CFIL(TBITS2) ;NAME
PUSHJ P,CODOUT
>;NOTENX
TENX<
MOVE B,SM1JFN
MOVE A,[POINT 7,RACS] ;NICE BIG TEMP AREA
SETZ C, ;STANDARD FORMAT
JSYS JFNS ;JFN TO STRING
HRRZ A,A
SUBI A,RACS
ADDI A,1 ;# WORDS IN NAME
PUSHJ P,CODOUT
MOVN B,A
HRLZ B,B ;AOBJN POINTER
MOVE A,RACS(B)
PUSHJ P,CODOUT
AOBJN B,.-2
>;TENX
NBAI02:
>;BAIL
; here put the initialization requests.
IFN 0,< ;ALL THIS IS PROCEDURIZED NOW
SKIPN INIPDP ;ANY ON THE QSTACK?
JRST INI.DN ;NO
MOVEI A,0 ;FOR THE LINK
TLZ FF,RELOC
PUSHJ P,CODOUT
MOVEI B,%INLNK
PUSHJ P,LNKOUT ;PUT OUT THE LINK
TLO FF,RELOC
QBEGIN (INIPDP) ;GET READY TO TAKE SOME OUT
NX.INI: QTAKE (INIPDP) ;TAKE NEXT ENTRY
JRST INI.D1 ;DONE
PUSHJ P,CODOUT ;PUT OUT THE REQUEST
JRST NX.INI
INI.D1: MOVEI A,0
TLZ FF,RELOC
PUSHJ P,CODOUT
INI.DN:
>;IFN 0
PUSH P,INIPDP ;INITIALIZATIONS
MOVEI B,%INLNK ;
PUSHJ P,QSTKOU
QFLUSH (INIPDP) ;FLUSH THE QSTACK
RGC <
PUSH P,RBSTK ;RECORD BLOCKS
MOVEI B,%RBLNK
PUSHJ P,QSTKOU
QFLUSH (RBSTK)
>;RGC
REN <
PUSHJ P,HISET ;BACK TO UPPER SEGMENT TO
>;REN
PUSHJ P,LNKMAK ;MAKE LINKAGE BLOCK
;1A
SKIPE LEAPIS ;ANY LEAP ASKED FOR
;; %AG% GITEMNO NOW CONTAINS THE LEAPIS FLAG
HRROS GITEMNO ;TELL RUNTIMS YES
SKIPN ITMSTK ;ANY DECLARED ITEMS?
JRST CONQN ;NONE
MOVE A,PCNT ;GET PROG. CNTR
MOVEM A,TINIT ;SAVE IT
MOVE A,ITMCNT ;NUMBER OF DECLARED ITEMS(INCLUDES GLOBALS)
TLZ FF,RELOC
PUSHJ P,CODOUT ;PUT IT OUT
MOVE B,ITMBEG ;START OF ITEM QSTACK
LPITMT: QTAKE (ITMSTK) ;GET ITEM,TYPE
JRST PNMOUT ;THROUGH, NO MORE ITEMS
PUSHJ P,CODOUT
JRST LPITMT ;LOOP
PNMOUT:
MOVE A,PCNT
MOVEM A,PINIT
TLZ FF,RELOC
SOS A,PNMSW ;NUMBER OF NAMES.
PUSHJ P,CODOUT ;PUT OUT SOME STUFF.
SKIPN PNMSW
JRST CONQN ;NO PNAMES -- SE ABOUT CONSTANTS.
MOVE B,PNBEG ;THE QTAKE POINTER
ITM1: QTAKE (PNLST)
JRST ITM2 ;ALL DONE.
MOVE PNT,A ;FOR EMITTER
HRRI A,NOUSAC
PUSHJ P,EMITER ; #CHARS,,POINTER TO BYTE POINTER.
JRST ITM1
ITM2:
CONQN:
;2
TLZ FF,RELOC
HRRZ LPSA,CONINT ;VARB-LIKE RING OF CONSTANTS.
JUMPE LPSA,STRGO
REN <
MOVSI D,RECURS ;GET REAL LIVE CONSTANTS FIRST
PUSHJ P,INTLOP
PUSHJ P,LOSET ;SWITCH TO LOWER SEGMENT IF HISW
HRRZ LPSA,CONINT ;NOW GET CONSTANTS WHICH WERE
JUMPE LPSA,STRG1 ; (IF ANY LEFT)
MOVEI D,0 ;UNIQUELY CREATED AS REFERENCE
PUSH P,INTRET ; PARAMS
; PUSHJ P,INTLOP
>;REN
INTLOP:
REN <
TDNE D,$TBITS(LPSA) ;THIS TIME?
JRST GOLEFT ; NO, WAIT FOR LOWER SEGMENT
>;REN
HRLZ B,$ADR(LPSA) ;FIXUP
JUMPE B,NOINT ;NOT USED
HRR B,PCNT
PUSHJ P,FBOUT
MOVE A,$VAL(LPSA) ;VALUE
PUSHJ P,CODOUT ;A WORD FOR IT.
NOINT:
REN <
PUSHJ P,URGCNM ;REMOVE FROM RING
GOLEFT:
>;REN
LEFT ,%RVARB,INTRET
JRST INTLOP ;LOOP UNTIL DONE.
INTRET:
REN <
POPJ P,.+1
STRG1: PUSHJ P,HISET ;BACK TO UPPER
>;REN
STRGO: HRRZ LPSA,CONSTR ;STRING CONSTANT RING.
JUMPE LPSA,BILGO
STRLOP:
MOVS B,$ADR(LPSA) ;FIXUPS
JUMPE B,[SKIPN B,$VAL(LPSA) ;SEE IF STORED IN PRE-LOADED ARRAY
JRST NOSTR ;NOT USED AT ALL.
HRR B,PCNT ;NOW XWD FIXUP,,PCNT
PUSHJ P,FBOUT ;EMIT IT.
JRST PUTIT]
HRLZ B,$ADR(LPSA) ;FIXUP FOR FIRST WORD.
JUMPE B,.+3
HRR B,PCNT
PUSHJ P,FBOUT
HRRZ A,$PNAME(LPSA) ;COUNT OF CHARACTERS.
PUSHJ P,CODOUT
HLLZ B,$ADR(LPSA) ;FIXUP FOR SECOND WORD.
JUMPE B,.+3
HRR B,PCNT
PUSHJ P,FBOUT ;OUTPUT THE FIXUP.
JUMPE A,NOSTR ;IN CASE NULL FLIES BY.
HRLI A,(<POINT 7,0>) ;BYTE POINTER
HRR A,PCNT
ADDI A,1 ;POINT TO .+1
SKIPN B,$VAL(LPSA) ;FIXUP FROM PRE-LOADED ARRAY IF ANY.
JRST .+3
HRR B,A ;THE PCNT FOR ASCII
PUSHJ P,FBOUT ;GO GUYS.
TLO FF,RELOC
PUSHJ P,CODOUT
TLZ FF,RELOC
PUTIT: HRRZ B,$PNAME(LPSA) ;COUNT AGAIN.
ADDI B,4
IDIVI B,5 ;B HAS NUMBER OF WORDS.
HRRZ C,$PNAME+1(LPSA) ;POINTER TO FIRST WORD.
STLL: MOVE A,(C)
PUSHJ P,CODOUT
AOS C
SOJG B,STLL
NOSTR:
LEFT ,%RVARB,BILGO
JRST STRLOP ;LOOP FOR ALL STRINGS.
;3
BILGO:
MOVE LPSA,VARB
CAIE LPSA,RESYM ;IT SHOULD BE HERE
ERR <DRYROT -- DONES>
BILOP: HRRZ B,$ADR(LPSA) ;FIXUP
JUMPE B,BILR
TLNE FF,CREFSW ;CREFFING??
PUSHJ P,CREFDEF ;DEFINE THIS SYMBOL.
PUSHJ P,SOUT ;GENERATE EXTERNAL REQUEST
BILR: LEFT ,%RVARB,LIBGO
JRST BILOP ;LOOP UNTIL DONE
;4
; IF GAG, WILL GET ADDRESSES DIRECTLY (MOVEI)
LIBGO: MOVEI C,0
LIBLOP: SKIPN B,LIBTAB(C) ;FIXUP FOR THIS FCN.
JRST NONT
YESLIB: MOVSS B
MOVE A,LIBNAM(C) ;RADIX50 FOR THIS FCN.
PUSHJ P,SCOUT ;GENERATE THE REQUEST.
NONT: AOS C
CAIE C,LIBNUM
JRST LIBLOP ;LOOP UNTIL DONE.
;5
HRROI TEMP,SALIB+1 ;FAKE STRING DESCRIPTOR FOR SAIL LIBRARY
REN <
SKIPE HISW ;WANT RE-ENTRANT LIBRARY?
HRROI TEMP,SALIBH+1 ;YES
>;REN
POP TEMP,PNAME+1
POP TEMP,PNAME
MOVEI B,LBTAB ;PUT OUT LIBRARY SEARCH
PUSHJ P,PRGOUT ; REQUEST
BAIL<
SKIPG BAILON ;REQUEST SYS:BAIL.REL LOAD!MODULE
JRST NBAI08 ;NO BAIL
HRROI TEMP,BAIREL+1
POP TEMP,PNAME+1
POP TEMP,PNAME
MOVEI B,PRGTAB
PUSHJ P,PRGOUT
NBAI08:
>;BAIL
;6
PUSHJ P,FRBT ;FORCE BINARY.
MOVEI B,FXTAB
PUSHJ P,GBOUT ;AND FIXUPS.
MOVEI B,SMTAB
PUSHJ P,GBOUT ;AND SYMBOLS.
MOVEI B,PRGTAB
PUSHJ P,GBOUT ;AND PROGRAM/LIBRARY REQUESTS
MOVEI B,LBTAB
PUSHJ P,GBOUT
;;%BR%
;NOW SAVE THE COMPILER VERSION NUMBER, SO WE CAN CHECK AT STARTUP
MOVE A,[.VERSION]
MOVEM A,COMVER
;;%BR% ↑
;7
;NOW OUTPUT THE SPACE ALLOCATION BLOCK.
MOVE A,PCNT
MOVEM A,SPCPC ;PCNT FOR SPACE BLOCK.
MOVEM A,SLNKWD ;AND FOR LINK WORD.
HRRZ TEMP,SPCTBL ;NUMBER OF WORDS OF DATA
ADDI A,(TEMP) ;NUMBER OF WORDS IN OBJECT MODULE
MOVEM A,PCNT
MOVEI B,SPCTBL ;SPACE TABLE
;;#TR# (2 OF 3) USE BLOCK COUNT
; AOS TEMP,SPCTBL ;ONE MORE (A ZERO)
; MOVEI A,=18
; CAIG A,(TEMP)
; HRRM A,SPCTBL ;MAKE SURE NO OVERFLOW HAPPENS
AOS SPCTBL ;ONE MORE (FOR THE ZERO)
;;#TR# ↑
PUSHJ P,GBOUT
MOVEI TEMP,2 ;SPACE BLOCK IS TYPE 2
MOVEM TEMP,LNKNM
MOVE B,SDSCRP ;LINK BLOCK
PUSHJ P,GBOUT ;AND LINK (LINK NUMBER 2)
MOVE B,EBDSC ;ASSUME SHOULD WRITE START ADDR, ETC.
TLNN FF,MAINPG ;A STARTING ADDRESS?
MOVE B,EBDSC1 ;NO, NO START ADDR, NO INIT CODE FIXUPS
REN <
PUSHJ P,HISET ;BE SURE PCNT IS IN UPPER SEGMENT
MOVE A,[XWD 5,2] ;ASSUME TWOSEG END BLOCK
MOVE TEMP,[IORM A,STRDDR] ;PUT CONSTANT SYMS INTO HI SEG
SKIPE HISW ;RIGHT?
JRST TSEND ;RIGHT
MOVE TEMP,[ANDCAM A,STRDDR] ;PUT CONSTANT SYMS INTO LOW SEG
MOVE A,[XWD 5,1] ;ONESEG END BLOCK
SUB B,[XWD 1,0] ;ONE FEWER WORDS TO WRITE
TSEND: MOVEM A,PRGBRK-2 ;TO CODE WORD OF LOADER BLOCK
MOVEI A,400000 ;SEGMENT CONTROL BIT
XCT TEMP ;STARTING ADDRESS INTO RIGHT SGMNT
HRRI TEMP,CONSYM+1 ;NOW
XCT TEMP ; PUT S., RPGSW, SAILOR REQUESTS
ADDI TEMP,2 ; INTO PROPER SEGMENT (SEE TOTAL,
XCT TEMP ; UNDER LOADER OUTPUT BLOCKS
ADDI TEMP,4 ; -- END BLOCKS SECTION
XCT TEMP
MOVE A,HCNT ;YES, GET CODE COUNT
MOVEM A,PRGBRK+1 ;LOW SEG BREAK IF TWO SEGMENTS
>;REN
MOVE A,PCNT ;ONLY OR HIGH SEG BREAK
MOVEM A,PRGBRK
PUSHJ P,GBOUT ;WRITE THE END BLOCKS.
POPJ P, ;ALL DONES
;ROUTINE TO PUT OUT A QSTACK FULL OF WORDS (ALL RELOC), FOLLOWED BY A ZERO
; AND PRECEDED BY A LINK WORD FOR SOME LOADER LINK
; PARAMS: QPDP IN (P), LINK NUMBER IN B
; SID: CLOBBERS B,A,LPSA,TEMP,FF(RELOC)
QSTKOU: SKIPN -1(P) ;QPDP EMPTY
JRST QS.XIT ;
MOVEI A,0 ;NO, PUT OUT A WORD FOR THE LINK
TLZ FF,RELOC ;LIKE SO
PUSHJ P,CODOUT ;
PUSHJ P,LNKOUT ;LINK GOES OUT
TLO FF,RELOC ;FOR ALL THE ADDRESSES
QBEGIN (<-1(P)>) ;SETS UP ACB
QS.OU1: QTAKE (<-1(P)>) ;
JRST QS.OU2 ;ALL DONE
PUSHJ P,CODOUT ;PUT OUT WORD
JRST QS.OU1 ;ITERATE
QS.OU2: MOVEI A,0 ;
TLZ FF,RELOC
PUSHJ P,CODOUT
QS.XIT: SUB P,X22
JRST @2(P)
COMMENT ⊗MEMORY and LOCATION EXECS, ALSO UINCLL⊗
↑↑ZBITS: SETZM BITS
POPJ P,
↑↑MEMI: SKIPA TBITS,[INTEGR]
↑↑MEMS: MOVE TBITS,BITS
TDNE TBITS,[XWD PROCED!SBSCRP,STRING];ILLEGAL TYPES
ERR <ILLEGAL DATA TYPE FOR MEMORY>,1
PUSHJ P,TYPDEC ;GET PARSE TOKEN
MOVEM A,PARRIG ;PUT IT AWAY
MOVE PNT,GENLEF+1 ;THE EXPRESSION GUY
MOVE SBITS,$SBITS(PNT) ;SEMANTICS OF THE EXPRN
HRRZ TEMP,$TBITS(PNT) ;IT BETTER BE INTEGER
;;#JY# RHT (11-2-72) ! TURN OFF SHORT
TRZ TEMP,SHORT ;TTURN OFF SHORT
TLNN SBITS,NEGAT ;AND NOT NEGATIVE
CAIE TEMP,INTEGR
JRST COERCI
TLNE SBITS,INAC ;LOADED?
JRST ITSINA ;YES
TLNE SBITS,ARTEMP ;IF NOT A TEMP
TLNE SBITS,INDXED ;OR INDEXED TEMP
JRST LODIT ;THEN LOAD IT
TLO SBITS,INDXED ;MAKE INDEXED TEMP
MOVEM SBITS,$SBITS(PNT) ;
MOVEM TBITS,$TBITS(PNT) ;
SETZM $VAL(PNT) ;
POPJ P,
LODIT: PUSHJ P,GETAN0 ;GET AN AC
EMIT <HRRZ> ;LOAD IT
MAKTMP: HRLZI SBITS,PTRAC!INDXED
PUSHJ P,GETTEM
HRRZM LPSA,ACKTAB(D) ;REMEMBER IT
HRRM D,$ACNO(LPSA)
MOVEM LPSA,GENRIG
POPJ P,
ITSINA: HRRZ D,$ACNO(PNT) ;GET AC #
PUSHJ P,REMOPA ;IF TEMP, REMOP IT
;;#JV# ! (10-20-72) RHT CANNOT USE AC0
JUMPE D,LODIT ;
TLZ SBITS,INAC ;
MOVEM SBITS,$SBITS(PNT) ;THIS WONT BE INAC ANY MORE
JRST MAKTMP ;NICE, NEW TEMP
COERCI: PUSH P,TBITS ;
MOVEI B,INTEGR
GENMOV (GET,POSIT!INSIST!GETD)
PUSHJ P,REMOP ;DONE OLD THING
POP P,TBITS
JRST MAKTMP ;NEW TEMP
↑↑LOCN: MOVE PNT,GENLEF+1 ;
PUSHJ P,GETAD
TLNN SBITS,PTRAC ;IF PTRAC THEN LEAVE ALONE
PUSHJ P,INCOR ;GET THE THING TO CORE
GENMOV (GET,ADDR) ;ADDRESS OF THIS
PUSHJ P,REMOP
MOVEI TBITS,INTEGR
HRLZI SBITS,INAC
GENMOV (MARK,0)
MOVEM PNT,GENRIG
PUSHJ P,TYPDEC
MOVEM A,PARRIG
POPJ P,
↑UINCLL: PUSHJ P,ALLSTO ;FLUSH ACS
XCALL (.UINITS) ;EMIT CALL TO USER INITIALIZATIONS
POPJ P,
;; MINOR RECORD EXECS
REC <
ZERODATA (RECORD VARIABLES)
↑QRCTYP: 0 ;HOLDS THE RECORD CLASS FOR THE RECORD_POINTER
↑URCIPR: 0 ;NAME OF HANDLER PROCEDURE FOR A RECORD
↑RCLASS: 0 ;RECORD CLASS HOLDER FOR MARK. MARK ALWAYS COPIES THIS
;INTO THE LEFT HALF OF $ACNO OF ANY TEMP IT MARKS
↑CURRCC: 0 ;NAME OF CURRENT RECORD CLASS BEING DEFINED
↑RCLPDL: 0 ;RECORD CLASS PDL
↑NLRCBK: 0 ;HOLDS SEMBLK FOR NULL RECORD
↑RCTEMP: 0 ; LIST OF CURRENTLY AVAILABLE RECORD TEMPS
↑RBSTK: 0 ; QPDP FOR -CNT,,ADR WORDS
ENDDATA
;NEW EXEC ROUTINES:
↑NLLREC: ;CREATES A NULL RECORD
SKIPE PNT,NLRCBK ;HAVE ONE?
JRST GOTNRC ;YEP, USE IT
SETZM SCNVAL ;NO MUST MAKE ONE
MOVE TBITS,[XWD CNST,PNTVAR]
MOVEM TBITS,BITS
HRROS RCLASS ;
PUSHJ P,CONINS;
HRROS $ACNO(PNT) ;THE UNIVERSAL CLASS
MOVEM PNT,NLRCBK
GOTNRC: MOVEM PNT,GENRIG
POPJ P,
↑RCCREM: MOVE PNT,GENRIG ;CALLED AFTER PRDEC
MOVEM PNT,CURRCC
POPJ P,
↑SETIRP: ;REMEMBER THAT THIS IS A RECORD POINTER
MOVEI A,PNTVAR
ORM A,BITS
POPJ P,
↑TWDIRC: ;REMEMBER RECORD CLASS
CAIE B,1 ;ANY_CLASS?
SKIPA PNT2,GENLEF
HRRZI PNT2,-1
CAIN B,2 ;AN IPR?
CAMN PNT2,CURRCC ;YES, IS IT ONLY TEMPORARILY THAT
SKIPA
ERR <BAD TYPE SPECIFICATION FOR RECORD POINTER>,1
SKIPE PNT,QRCTYP ;
JRST MULRCC ;A MULTIPLE RECORD CLASS
MOVEM PNT2,QRCTYP
POPJ P,
MULRCC: CAIN PNT,-1 ;THE SPECIAL "ANYTHING" FLAG
SKIPA TBITS,[PNTVAR!SHORT]; SO THAT WILL GET SOME MORE
PUSHJ P,GETAD ;IS THE THING THERE ALREADY A CLASS?
TRNN TBITS,LSTBIT ;THIS IS THE GIVEAWAY
JRST [ GETBLK ;GET A BLOCK FOR THE PURPOSE
TRO TBITS,LSTBIT ;FLAG IT
MOVEM TBITS,$TBITS(LPSA)
MOVEI TEMP,1
MOVEM TEMP,$PNAME(LPSA)
MOVE PNT,LPSA ; SAVE IT
EXCH LPSA,QRCTYP ; NOW LPSA IS THE THING USED TO HAVE
HRLI TEMP,(<POINT =18,0>) ;
HRRI TEMP,$ADR(PNT) ;A SURE ENOUGH BYTE POINTER
MOVEM TEMP,$PNAME+1(PNT) ;
IDPB LPSA,TEMP ;REMEMBER OLD QRCTYP
MOVEM TEMP,$SBITS(PNT) ;AND NEW VERSION OF BYTE POINTER
QPUSH (RCLPDL,PNT) ;SAVE THIS SO WE CAN KILL IT OFF
JRST .+1 ]
AOS TEMP,$PNAME(PNT) ;ONE MORE
CAILE TEMP,=12 ;
ERR <WE ONLY ALLOW UP TO TWELVE CLASSES AT A TIME FOR NOW>,1,CPOPJ
IDPB PNT2,$SBITS(PNT)
POPJ P,
↑RCBIT0:
MOVE A,[XWD SIMPLE,PROCED] ;PRETEND TO BE A SIMPLE PROCEDURE
ORM A,BITS
;;# # NEEDED TO FIX BITS BACK IF RECORD CLASS WAS ALREADY FORWARD
SKIPN PNT,GENLEF ;IF ANY
POPJ P,
PUSHJ P,GETAD ;FIND OUT WHAT THIS ID USED TO BE
TDNN TBITS,[XWD EXTRNL,FORWRD]
POPJ P, ;NOT ELIGIBLE
TRZE TBITS,PNTVAR ;IF NOT A RECORD CLASS
TRZN TBITS,SHORT
POPJ P, ;THEN LEAVE IT ALONE
ANDI SBITS,LLFLDM ;
CAME SBITS,LEVEL ;SAME LEVEL??
POPJ P, ;NOPE
EXTERN EQU
EXCH SP,STPSAV ;SAME PNAME??
PUSH SP,$PNAME(PNT)
PUSH SP,$PNAME+1(PNT)
PUSH SP,PNAME
PUSH SP,PNAME+1
PUSHJ P,EQU
EXCH SP,STPSAV
JUMPE 1,CPOPJ ;IF NOT, DO NOTHING
TDO TBITS,[XWD SIMPLE,PROCED]
MOVEM TBITS,$TBITS(PNT) ;IF SO, THEN MODIFY SO PRDEC
POPJ P, ;WINS
↑URCHLR: ;USER RECORD HANDLER PROCEDURE SPECIFICATION
MOVE PNT,GENLEF+1
MOVEM PNT,URCIPR
POPJ P,
↑NRCDO: ;MAKES A NEW RECORD
MOVEI D,1 ;RESULT WILL COME BACK IN 1
PUSHJ P,STORZ
MOVE PNT,GENLEF+1 ;DO A RECUUO 1
PUSHJ P,ADRINS ;WILL NEED AN ADCON
EMIT <RECUUO 1,NOUSAC>
MOVEI D,1 ;RESULT COMES BACK IN AC1
MOVEI TBITS,PNTVAR ;
MOVE PNT,GENLEF+1
MOVEM PNT,RCLASS
PUSHJ P,MARKME
MOVEM PNT,GENRIG ;THE TEMP
POPJ P,
↑RCCERR: ERR <SYNTAX ERROR IN RECORD CLASS DECLARATION>,1
POPJ P,
↑RCPERR: ERR <SYNTAX ERROR IN RECORD POINTER DECLARATION>,1
POPJ P,
>;REC
NOREC <
↑NLLREC:
↑RCCREM:
↑SETIRP:
↑TWDIRC:
↑RCBIT0:
↑URCHLR:
↑NRCDO:
↑RCCERR:
↑RCPERR:
↑RCFPIK:
↑RCFREF:
↑ENDRC:
ERR <DRYROT: RECORD EXEC CALLED IN NOREC SAIL SYSTEM>
>;NOREC
;; RCFPIK -- ROUTINE TO DECODE RECORD INDEX
REC <
EXTERN EQU
↑RCFPIK:
MOVE PNT,GENLEF+3 ;GET THE CLASS
HLRZ PNT2,%TLINK(PNT) ;INTERESTING THINGS ARE IN SECOND BLOCK
HLRZ PNT2,%TLINK(PNT2)
JUMPE PNT2,RCFP.3 ;NO FIELDS, MUST LOSE
MOVSS POVTAB+6 ;INCASE OF OVERFLOW
EXCH SP,STPSAV ;GET THE STRING STACK
RCFP.1:
PUSH SP,$PNAME(PNT2) ;CHECK TO SEE IF THE SAME
PUSH SP,$PNAME+1(PNT2)
PUSH SP,PNAME ;THE ONE WE SCANNED
PUSH SP,PNAME+1 ;
PUSHJ P,EQU ;CHECK FOR EQUAL
JUMPN 1,RCFP.2 ;YES
HRRZ PNT2,%RVARB(PNT2) ;GO ON TO NEXT
JUMPN PNT2,RCFP.1 ;IF THERE IS A NEXT
RCFP.2: EXCH SP,STPSAV ;SAVE PDL AGAIN
MOVSS POVTAB+6 ;PUT PDLOV BACK
CAIN PNT2,0 ;DID WE GET ONE
RCFP.3: ERR <COULD NOT FIND THE SPECIFIED SUBFIELD>,1
MOVEM PNT2,GENRIG ;UGH! IF LOSES, WILL DO SOMETHING ELSE
POPJ P,
>;REC
;; RCFREF -- EXEC ROUTINE FOR HANDLING RECORD FIELD REFERENCES
REC <
↑RCFREF:
HRRZ PNT,GENLEF+1 ;GET THE RECORD ID
PUSHJ P,GETAD ;GET THE SEMANTICS
TRNE TBITS,PNTVAR ;BETTER BE SURE A POINTER VARIABLE
TRNE TBITS,777777-(PNTVAR!GLOBL) ;BETTER LOOK LIKE THIS
ERR <RCIREF OF SOMETHING NOT A RECORD PTR>,1
NORGC <
TLNE SBITS,ARTEMP ;A TEMP??
TLNE SBITS,FIXARR ;EVEN IF SO, FIXARR IS JUST NORMAL
JRST RCR1 ;DO THE STANDARD CASE
;;% % treat all indxed temps in good way (unless later get in trouble)
; TLNN SBITS,INDXED ;INDEXED TEMP?
; JRST RUINDX ;NOPE, ASSUME CAME FROM SOME BAD THING
; HRRZ LPSA,$VAL2(PNT) ;THE SUBFIELD FLAG
; JUMPN LPSA,RCR1 ;A SUBFIELD INDEXED TEMP IS JUST NORMAL
; GENMOV (GET,MRK!INDX) ;GET THE INDEXED TEMP INTO AN AC
TLNE SBITS,INDXED
JRST RCR1
;;% %
>;NORGC
RUINDX: PUSH P,PNT ;SINCE WILL REMOP RIGHT AWAY
PUSHJ P,RCR1 ;GET A NEW INDEXED TEMP
HRROS %TLINK(PNT) ;& MARK IT SO REMOP UNDOES REF COUNT
POP P,LPSA ;FOR THE REMOP OF OUR ORIGINAL TEMP
JRST REMOPL ;GO REMOP THE BEASTIE
RCR1: GENMOV (ACCESS,0) ;GET ACCESS TO THE THING
PUSHJ P,GETAN0 ;GET AN INDEX AC
EMIT <SKIPN > ;BE SURE OK
XCALL <$RERR> ;MAY WANT SOMETHING BETTER LATER
;TOO BAD CANNOT ELIMINATE THE
;REDUNDENT CHECKING, AS IN
; X←FOOC:1[R]+FOOC:2[R]
HLRZ LPSA,$ACNO(PNT) ;GET THE CLASS ID
HRRZ PNT2,GENLEF+3 ;AS HE SPECIFIED IT
PUSHJ P,SUBFOK ;TEST FOR CLASS AGREEMENT
ERR <CLASS DISAGREEMENT ON RECORD FIELD>,1
HLRZ PNT2,%TLINK(PNT2) ;THE INTERESTING THINGS ARE IN THE SECOND
GOTFS: MOVE PNT,GENLEF+2 ;GOT FIELD SEMANTICS
SETZB TBITS,SBITS
PUSHJ P,GETTEM ;GET A TEMP
;& FILL IN THESE BITS
MOVE TBITS,$TBITS(PNT)
HRLZI SBITS,ARTEMP!PTRAC!INDXED; PROMISE TO BE ARITHMETIC
TLZ TBITS,OWN!FORMAL!MPBIND ;RANDOM BAD GUYS THAT MAY BE ON
MOVEM SBITS,$SBITS(LPSA)
MOVEM TBITS,$TBITS(LPSA)
TLNE TBITS,SBSCRP ;ARRAYS ARE FUNNY
HRLM PNT,$VAL2(LPSA) ;SAVES THE FIELD NAME SO THAT ARRSB WILL WIN
TRNE TBITS,PNTVAR ;A POINTER ITSELF??
TRNE TBITS,ITMVAR!ITEM!SHORT
TLZA D,-1 ;NO, JUST DO THE MARKING -- CLASSID 0
HLL D,$ACNO(PNT) ;THE CLASS ID OF THIS FIELD
MOVEM D,$ACNO(LPSA) ;REMEMBER RCLASS,,ACNO
;;#SS# ! RHT ALSO REMEMBER IN ACKTAB
HRRM LPSA,ACKTAB(D) ;REMEMBER I DID IT
MOVE PNT,LPSA ;FOR TYPDEC
MOVEM PNT,GENRIG ;THIS IS WHAT WE HAVE
PUSHJ P,TYPDEC ;GET CORRECT TYPE
MOVEM A,PARRIG ;
HRRZ LPSA,GENLEF+2 ;GET THE SEMANTICS OF THE FIELD ID
HRRE B,$ADR(LPSA) ;ADR FIELD IS THE INDEX
MOVEM B,$VAL(PNT) ;REMEMBER IT AS SUCH
HLLOS $VAL2(PNT) ;JUST USE -1 AS A FLAG FOR NOW
NORGC <
MOVE PNT2,TPROC ;PUT ON SUBFIELD TEMP RING
HLRZ PNT2,%TLINK(PNT2) ;IT IS HOMED IN THE SECOND PROC SEMBLK
HRLZ LPSA,PNT2 ;BACK POINTER IS INTO PROC SEMBLK
HRR LPSA,%RVARB(PNT2) ;THE FIRST THERE NOW
MOVEM LPSA,%RVARB(PNT) ;LINKS FOR NEW SUBFIELD
TRNE LPSA,-1 ;AM I THE VERY FIRST SUCH?
HRLM PNT,%RVARB(LPSA) ;NOPE, HE LINKS BACK TO ME NOW
HRRM PNT,%RVARB(PNT2) ;NEW LIST HEADER
MOVE PNT2,GENLEF+1 ;THE RECORD POINTER AGAIN
HRLM PNT2,%TLINK(PNT) ;BOY IS ALL THIS HAIRY
;POINTS BACK SO THAT DEREF KLUGE WORKS
>;NORGC
POPJ P,
;NOTE THAT I DON'T EVEN DO A REMOP YET ON THE RECORD POINTER
; THE REMOP WILL HAPPEN AUTOMATICALLY WHEN I REMOP THE NEW INDEXED TEMP
>;REC
;; RECORD TYPE JUSTIFICATION ROUTINE
REC <
↑SUBFOK: CAMN LPSA,PNT2 ;TAKES A CLASS OR CLASS LIST IN PNT2 & LPSA
JRST SBFSKP ;SKIP RETURNS IF HAVE NON ZERO INTERSECTION
;CHANGES NO ACS
CAIE LPSA,-1 ;IF EITHER IS THE UNIVERSAL CLASS
CAIN PNT2,-1 ;WE WILL KNOW WE ARE WINNING
JRST SBFSKP
PUSHJ P,SBFTRY ;TRY SUBFIELDING
JRST [ ;LOST, TRY OTHER CASE
EXCH PNT2,LPSA ;
PUSHJ P,SBFTRY ;SKIP RET MEANS WINNER
SOS (P) ;UNDO WINNAGE
EXCH PNT2,LPSA ;
JRST SBFSKP
]
SBFSKP: AOS (P) ;A GREAT WIN
SBFRET: POPJ P,
SBFTRY:
PUSH P,C ;VERIFY CLASS OK
PUSH P,TEMP
PUSH P,LPSA
MOVE C,$TBITS(LPSA)
TRNN C,LSTBIT ;THIS BIT IS THE GIVEAWAY
JRST POPOFF ;LOSER
HRRZ C,$PNAME(LPSA) ;
MOVE TEMP,$PNAME+1(LPSA)
LPLP.1: JUMPE C,POPOFF
ILDB LPSA,TEMP ;
PUSHJ P,SUBFOK ;TEST IT OUT
SOJA C,LPLP.1 ;LOOP BACK
AOS -3(P) ;WILL SKIP RET ONLY IF LOSE
POPOFF: POP P,LPSA
POP P,TEMP
POP P,C
POPJ P,
>;REC
;; ROUTINE TO HANLDE REFERENCE COUNT ADJUSTMENT
REC <
NORGC <
;;ROUTINE TO EMIT A DEREFERENCEING INSTRUCTION FOR THE THING IN PNT
;;WILL EVENTUALLY EMIT A <RECUUO 0,>, USUALLY. IF HOWEVER THE THING
;;HAS DANGLING REFERENCES IN THE FORM OF INDEXED TEMPS, WILL INSTEAD
;;EMIT CODE TO ADJUST THE REFERENCE COUNT BY N+C, WHERE N IS THE
;;NUMBER OF SUCH TEMPS, AND C IS USUALLY -1. (IF C=0, THEN THE EFFECT
;;OF THIS ROUTINE WILL BE TO "CORRECT" THE REFERENCE COUNT -- USEFUL
;;WHEN YOU MUST PASS A RECORD BY REFERENCE). IF N+C LSS 0, THEN THE CODE
;;<RECUUO,0> WILL BE PUT OUT ABS(N+C) TIMES. OTHERWISE THE COUNT IS BUMPED
;;BY ABS(N+C). IN ANY EVENT, ANY SUCH TEMPS THAT POINT TO THE PNT THING ARE
;;MARKED (BY SETTING THEIR BACK REFERENCE POINTER (LH OF %TLINK) TO -1)
;;SO THAT THEY WILL EMIT A <RECUUO 0,-1(AC)> WHENEVER THEY GET REMOPPED
;;AND THE THING IN PNT WILL GET ITS REFCOUNT BUMPED BY THAT MUCH.
;;
;;PARAMETERS: PNT = THING
;; C = INITIAL OFFSET COUNT = "TRUE" ADJUSTMENT
;; SET TO -1 FOR SIMPLE DEREFERENCING
;; SET TO 0 FOR REF PARAM "CORRECTION"
;;ENTRY POINTS:
;; ↑RFCADJ: <DOES THE WHOLE THING, INCLUDING INDEXED TEMPS>
;;
;;MODIFIES LPSA,C,A,TEMP
↑RFCADJ:
PUSH P,FF
PUSH P,PNT2
PUSH P,D ;BECAUSE ACCESS MAY MUNGE
PUSH P,TBITS
PUSH P,SBITS
PUSH P,B
HRRZ B,TPROC ;WILL CRAWL DOWN DEPENDENTS LIST
HLRZ B,%TLINK(B) ;POINTER IS IN SECOND BLOCK
JRST CKL.1 ;COUNT UP
CKL: HLRZ LPSA,%TLINK(B) ;BACK POINTER
CAIN LPSA,(PNT) ;IS THIS ONE?
JRST [ HRROS %TLINK(B) ;THIS WAS ONE, MARK IT
AOJA C,.+1 ;AND BUMP THE COUNT
]
CKL.1: HRRZ B,%RVARB(B) ;GO ON TO NEXT
JUMPN B,CKL
LCKD: JUMPE C,RFCXIT ;HAVE TO ADJUST COUNT?
PUSH P,C ;WHAT A PARANOID
GENMOV (ACCESS,GETD) ;GET ACCESS
POP P,C
JUMPG C,BMCNT ;MUST INCREMENT
MOVE A,[RECUUO 0,NOUSAC] ;DROP COUNT BY ONE
PUSHJ P,EMITER ;EMIT IT
AOJL C,.-1 ;HANG IN THERE UNTIL DONE
RFCXIT: POP P,B
POP P,SBITS
POP P,TBITS
POP P,D
POP P,PNT2
POP P,FF
POPJ P,
BMCNT:
EMIT <SKIPN TEMP,NOUSAC> ;FETCH THE RECORD ADDRESS
XCALL <$RERR> ;BETTER NOT BUMP REF COUNT OF NULL
HRLOI A,(<AOS (TEMP)>) ;SHOULD PUT <AOS -1(<INDEX AC>)> INTO A
TLZ FF,RELOC ;AN ABSOLUTE VALUE
PUSHJ P,CODOUT ;EMIT ONE OF THESE
SOJG C,.-1 ;PUT OUT A MESS OF THEM
JRST RFCXIT ;DONE
>;NORGC
>;REC
DSCR MAKBUK, FREBUK
CAL PUSHJ
PAR current value of SYMTAB
DES MAKBUK allocates a new Semblk, copies current Symtab
bucket list into it; saves a pointer to the old one --
see main SAIL data descriptions for details. This is
how scope is handled, because...
FREBUK deletes this Semblk, restores old pointer. It is
up to somebody else (ALOT) to delete all the local Semblks
which are no longer available via SYMTAB
This junk is unnecessary for STRCON and CONST buckets, since
all such entities are global (one bucket list)
SEE main SAIL data definitions in SAIL
SEE BLOCK, UP1, UP2, etc.
⊗
↑MAKBUK:
GETBLK ;MAKE A NEW BLOCK
EXCH LPSA,SYMTAB ;SYMTAB IS NOW UPDATED
HRLI PNT,(LPSA)
HRR PNT,SYMTAB ;PREPARE TO BLT
HRRZM LPSA,BLKLEN-1(PNT) ;TIE TO OLD ONE
MOVE TEMP,PNT
BLT PNT,BLKLEN-2(TEMP) ;COPY BUCKET
POPJ P,
↑FREBUK:
MOVE LPSA,SYMTAB
HRRZ A,BLKLEN-1(LPSA) ;TIE
MOVEM A,SYMTAB
FREBLK ;RELEASE THE BLOCK
POPJ P,
BEND GENDEC
SUBTTL ERROR MESSAGE EXECS
BEGIN ERRORS
;THE FIRST ROUTINE ALWAYS PRINTS OUT A NEAT MESSAGE....
JOBERR←←42
DEFINE XX (NAME,MESSG,CODE) <
↑NAME : ERR. 1,[ASCIZ/MESSG/]
;;##LN##KVL - MAKES EXECUTION OF BAD CODE HARDER
IFN CODE,<
HLLOS JOBERR ;CAUSES LOADER TO DELETE EXECUTION (HOPEFULLY)
>;CODE
POPJ P,
>;XX
XX (ER1,<START YOUR PROGRAM WITH BEGIN OR ENTRY - WILL SCAN FOR BEGIN.>,1)
XX (ER2,<BAD ENTRY STATEMENT - WILL SCAN FOR BEGIN.>,1)
XX (ER3,<YOU SEEM TO HAVE USED A , INSTEAD OF A ; BETWEEN DECLARATIONS.>,0)
XX (ER4,<BOGUS IDENTIFIER IN IDENTIFIER LIST.>,1)
XX (ER5,<INSERTING FORGOTTEN SEMI-COLON.>,0)
XX (ER6,<DELETED EXTRA SEMI-COLON.>,0)
XX (ER7,<SYNTAX ERROR. CURRENT STATEMENT OR DECLARATION WILL BE FLUSHED.>,2)
XX (ER8,<SYNTAX ERROR AT END OF EXPRESSION - WILL CHECK FOR PARENTHESES MISMATCH.>,0)
XX (ER15,<ARRAYS SUBSCRIPTING USES BRACKETS! PARENTHESIS REPLACED.>,0)
XX (ER24,<CANNOT BEGIN A DECL OR STMNT LIKE THIS.
(MOST LIKELY A DECL AFTER A STMNT)>,1)
XX (ER33,<NEED AN "UNTIL" AFTER THE STATEMENT OF A "DO ...UNTIL ...">,1)
XX (ER34,<BAD BLOCKING - TOO FEW ENDS.>,1)
XX (ER35,<UNDECLARED ARRAY>,0)
XX (ER36,<MISSING ( INSERTED.>,0)
XX (ER37,<EXTRA ) DELETED.>,0)
XX (ER38,<REQUIRE A BOOLEAN OR AN ALGEBRAIC EXPRESSION HERE.>,1)
XX (ER39,<REQUIRE A CONSTANT ALGEBRAIC EXPRESSION HERE.>,1)
XX (ER40,<INSERTED MISSING ).>,0)
XX (ER41,<YOU CANNOT BEGIN AN EXPRESSION LIKE THIS.>,1)
XX (ER48,<MISSING RIGHT CURLY BRACKET INSERTED.>,0)
XX (ER59,<NEED AN ASSOCIATIVE EXPRESSION HERE.>,1)
XX (ER66,<USE A BEGIN OR A ( AFTER A CASE.>,1)
XX (ER68,<YOU FORGOT TO INCLUDE THE CONTEXT.>,1)
XX (ERTRAP,<QTRAP: SEE A SAIL HACKER>,1);
DEFINE YY (NAME,MESSG) <
↑NAME: ;SHOULD REALLY BE AN ERRPRI
PUSH P,A
MOVEI A,[ASCIZ /MESSG
/]
PUSHJ P,PRINT.
POP P,A
POPJ P,
>
YY (ERR101,<STATEMENT FLUSHED.>)
YY (ERR102,<BLOCK FOUND WHILE FLUSHING STATEMENT - WILL TRY TO PARSE IT.>)
YY (ERR103,<EXTRA ) DELETED.>)
YY (ERR104,<MISSING ) INSERTED.>)
YY (ERR105,<BLOCK END OKAY - FLUSH OF STATEMENT CONTINUES.>)
YY (ERR106,<MISSING ; INSERTED.>)
YY (ERR107,<SORRY - CAN'T CONTINUE.>)
YY (ERR108,<DISREGARD THE ABOVE AND REMEMBER TO USE BRACKETS ON ARRAYS.>)
YY (ERR109,<CVMS TAKES AS AN ARGUMENT A MACRO NAME - PARAMETERS ARE IGNORED>)
YY (ERR110,<DECLARATION TAKES AN IDENTIFIER AS AN ARGUMENT - FLUSH REST OF STATEMENT>)
YY (ERR111,<CHECK!TYPE ONLY TAKES VALID DECLARATIONS OR PARTS OF DECLARATIONS AS ARGUMENTS - FLUSH REST OF STATEMENT>)
XX (ERR112,<BIND OR ? USED INCORRECTLY, WILL BE IGNORED>,1)
XX (ERR113,<PROPS REQUIRES SINGLE ITEM EXPR AS ARGUMENT>,1)
XX (ERR114,<PROPS MAY BE ASSIGNED ONLY ARITHMETIC VALUES>,1)
XX (ERR115,<MISSING ARRAY BOUND-PAIR LIST>,1)
XX (ERR116,<INVALID SAMEIV SYNTAX>,1)
XX (ERR117,<INVALID IN!CONTEXT SYNTAX>,1)
XX (ERR118,<MISUSE OF EXPR!TYPE>,1)
XX (ERR119,<INVALID CONTEXT ELEMENT SYNTAX>,1)
XX (ERR120,<ILLEGAL ASSIGNC PARAMETER NAME>,1)
XX (ERR121,<CONDITIONAL COMPILATION PROBLEM PROBABLY EXTRA ENDC OR ELSEC>,1)
XX (ERR122,<NOMAC REQUIRES A MACRO NAME WITH NO ARGUMENTS>,1)
XX (ERR123,<CVPS REQUIRES A LEFT PARENTHESIS HERE>,0)
XX (ERR124,<ILLEGAL CVPS PARAMETER NAME>,1)
;; #QT# BETTER DIAGNOSTIC FOR ELSE
XX (ERR125,<EXTRANEOUS "ELSE", WILL BE IGNORED>,1)
DSCR SCNBAK,POPBAK,KILPOP,QREM2,QTYPCK;
PRO SCNBAK,POPBAK,KILPOP,QREM1,QREM2,QTYPCK;
DES Error recovery execs:
SCNBAK: backs scanner up by one token.
POPBAK: returns you to the previous production.
KILPOP: returns the production control stack (stack productions pushj,popj stuff)
to its pristine state.
QREM1,QREM2: Called at the end of a block to delete untyped identifiers still left
on the VARB ring.
QTYPCK: Called from PRE in TOTAL. Every time one GENMOVs with CONVRT on, QTYPCK
checks to see if the type bits of either the source or destination are zero in the
rh, and gives the untyped one the type of the other. If the source is undeclared,
then QTYPCK corrects the source, and if the source is a temp, it corrects the
procedure or array that generated the temp.
⊗
;BACKS THE SCANNER UP BY ONE TOKEN
↑SCNBAK: MOVE A,PARLEF
MOVEM A,SAVPAR
MOVE A,GENLEF
MOVEM A,SAVSEM
TLO FF,BAKSCN ;SCANNER IS AHEAD.
POPJ P,
;RETURNS YOU TO THE PREVIOUS PRODUCTION
↑POPBAK: MOVE A,SAVPOP
MOVEM A,-2(P) ;PRODUCTION POINTER.
POPJ P,
;FLUSHS THE PRODUCTION CONTROL STOCK (used for the production pushj popj stuff)
↑KILPOP:
MOVE TEMP,PCSAV ; GET PRODUCTION CONTROL STACK POINTER
KPJ: SKIPGE -1(TEMP) ; IS THIS THE JUMP TO PARSE
JRST KILDUN ; YES, LEAVE IT AND GO HOME
POP TEMP,-1(TEMP) ; NO, GO DOWN ONE
JRST KPJ
KILDUN: MOVEM TEMP,PCSAV
POPJ P,
;CALLED AT THE END OF A BLOCK TO DELETE THE UNTYPED IDENTIFIERS(EXCEPT PROCEDURES)
↑QREM1: SKIPA LPSA,GENLEF+1 ; GET THE BLOCK
↑QREM2: MOVE LPSA,GENLEF+2
JUMPE LPSA,QFIN ; THIS BEGIN HASN'T A BLOCK SEMBLK
QL: HRRZ LPSA,%RVARB(LPSA) ; GO RIGHT ON VARB RING...
QL1: JUMPE LPSA,QFIN ; UNTIL YOU GET TO THE END.
MOVE TBITS,$TBITS(LPSA) ; THE TYPE...
JUMPN TBITS,QL ; IS OKAY...
HRRZ TBITS,%RVARB(LPSA) ;SAVE THE NEXT GUY..........
PUSHJ P,DESTRO ; KILL THE BASTARD!
MOVE LPSA,TBITS
JRST QL1
QFIN: POPJ P,
;DESTROYS AN IDENTIFIER - REMOVES FROM VARB RING - NULLIFIES HASH AND STR RING
↑QDESID:
MOVE LPSA,GENLEF+1 ; GET THE FATED IDENTIFIER
DESTRO:
TLNE FF,CREFSW
PUSHJ P,CREFDEF ; DEFINE WHAT WE'RE KILLING TO CREF
PUSHJ P,URGSTR
PUSHJ P, URGVRB ; UNRING IT
FREBLK (LPSA)
POPJ P,
;CALLED FROM PRE OF GENMOV - CHANGES UNTYPED TO A REASONABLE TYPE
↑QTYPCK:
TRNN TBITS,-1 ; IS THE SOURCE OF UNDECLARED TYPE
JRST QMATCH ; YES, GO GIVE IT THE DESTINATIONS TYPE
TRNE B,-1 ; IS THE DESTINATION UNTYPED
POPJ P, ; NO, GO HOME
HRR B,TBITS ; YES, GIVE IT THE SOURCE TYPE
POPJ P,
QMATCH:
HLR TBITS,$SBITS(PNT) ; GET SOURCE SEMANTICES
HRRM B,$TBITS(PNT) ; GIVE THE SOURCE THE DESTINATION TYPE
TLNN TBITS,INAC!ARTEMP!INUSE ; IS IT A TEMP
JRST .+3 ; NO, GO BACK
HLR TBITS,%TLINK(PNT) ; GET THE ARRAY OR PROCEDURE
HRRM B,$TBITS(TBITS) ; GIVE IT THE GOOD TYPE
HRR TBITS,B ; GIVE TBITS THE GOOD TYPE
POPJ P,
DSCR UNDEC -- Undeclared identifiers;
PRO UNDEC;
DES Declares an identifier globally or locally and modifies symbol table nicely.
When the token I is scanned at the identifier switch areas S1 and EX1 in
HEL, we call UNDEC. Since TYPDEC (called by the scanner) returns I if there are
no type bits on, we may have merely an untyped identifier, so we don't need to
declare it again. Otherwise, we create an empty semblk, then link it on the
appropriate varb ring, hash bucket and string ring for global or local declaration.
We make the assumption that the user has declared something in the global block,
and thus use the block semblk referenced by QQBLK which is loaded at the first
call of the exec BLOCK.
⊗
;ENTERS IDENTIFIER ON LOCAL OR GLOBAL LEVEL
↑UNDEC: SKIPE A,GENLEF ; IF THE THING IS DECLARED...
POPJ P, ; THEN GO BACK ELSE...
HRRZI LPSA,PNAME-1 ;SET UP LPSA WITH IDD'S NAME
ERR <UNDECLARED IDENTIFIER: >,3
HRRZI A,INTEGR ; SOMETHING SIMPLE TO DECLARE
MOVEM A,BITS
PUSHJ P,ENTERS ; GO MAKE IT
MOVE A,NEWSYM ; GET IT BACK
MOVEM A,GENRIG ; PUT IT OUT
POPJ P, ; RETURN
;;%AC% REMOVE GLOBAL DECLARATION OPTION
IFN 0 <
;The following is how to declare an identifier in the outermost block.
;Social pressures forced its removal from the error recovery, but I
;thought I'd leave it around for a while in case the algorithm is needed
;for another purpose. -kvl
GLOBA: SKIPN PNT,QQBLK ; GET THE HIGHEST BLOCK WITH DECLARATION
JRST LOCA ; WE ARE THE HIGHEST BLOCK
GETBLK NEWSYM ; GET A NEW SEMBLK
MOVE LPSA,NEWSYM
HRROI PNT2,PNAME+1 ; PDP FOR NAME
POP PNT2,$PNAME+1(LPSA)
POP PNT2,$PNAME(LPSA)
PUSHJ P,RNGSTR ; PUT IT ON THE STRING RING
HRRZ PNT,%RVARB(PNT) ; THE FIRST MEMBER OF BLOCK'S VARB RING
HRRZ PNT2,$SBITS(PNT) ; GET THE LEVELS,ZERO THE SBITS
MOVEM PNT2,$SBITS(LPSA)
HRLM LPSA,%RVARB(PNT) ; LPSA ← 1ST
HRRM PNT,%RVARB(LPSA) ; LPSA PNTS TO 1ST
MOVE PNT,QQBLK ; GET THE HIGHEST BLOCK
HRRM LPSA,%RVARB(PNT) ; BLK IN LPSA
HRLM PNT,%RVARB(LPSA) ; BLK ← LPSA
MOVE PNT,HPNT ; GET HASH(BUCK(QQBLK)) INTO B
SUB PNT,SYMTAB ; CORRECT ADDRESS TO...
MOVE C,PNT ; GENERALIZED HPNT FOR LATTER
MOVE PNT2,QQBLK
HRRZ PNT2,%TBUCK(PNT2)
ADD PNT,PNT2 ; ... TO THE OUTER LEVEL
XCT PNT
HRRZ B,LPSA ; B = HASH(BUCK(QQBLK))
HRRZ A,SYMTAB ; INITIALIZE
;GO UP THE BLOCKS, FIXING THE HASH BUCKETS OR HASH CHAINGS THAT USED TO PT TO B
HASHL: MOVE PNT,C ; GET GENERAL HPNT
ADD PNT,A ; CORRECT HPNT TO THIS LEVEL
XCT PNT ; LPSA PNTS TO HEAD OF HASH CHAIN THIS BUCKET
HRRZ PNT2,LPSA
CAMN B,PNT2 ; DOES B = HASH(BUCK(A)) ?
JRST BUCIT ; YES,GO FIX THIS BUCKET
SKIPN QQFLAG ; NO, FIX THE CHAIN.
JRST UPBUCK ; WE ALREADY FIXED THE CHAIN,GO UP A BLOCK
SETZM QQFLAG ; MAKE SURE WE ONLY DO THIS ONCE
UPCHAI: MOVE PNT,PNT2 ; FIND THE TOP GUY OF THE CHAIN BEFORE QQBLK LEVEL
HRRZ PNT2,%TBUCK(PNT2) ; GO UP
CAME B,PNT2 ; ARE WE AT QQBLK LEVEL YET?
JRST UPCHAI ; NO, GO UP THE CHAIN
HRRZ PNT2,NEWSYM ; GET THE GUY
HRRM PNT2,%TBUCK(PNT) ; TOP-NOT-ON-QQBLK-GUY PNTS TO UNDECLARED-GUY
HRRM B,%TBUCK(PNT2) ; UNDECLARED-GUY PNTS TO 1ST-OF-QQBLK-LEVEL-GUY
JRST UPBUCK ; FINE, GO UP A BUCKET
BUCIT: MOVE PNT2,NEWSYM ; WE ARE GOING TO FIX THE BUCKET BY
HRRM LPSA,%TBUCK(PNT2) ; DOING A REGULAR HASH
HRR LPSA,PNT2
TLO PNT,2000
XCT PNT
JRST UPBUCK ; GO UP A BUCKET
UPBUCK: MOVE PNT,QQBLK ; GET THE TOP BUCKET
HRRZ PNT,%TBUCK(PNT)
CAMN A,PNT ; ARE WE AT THE TOP
JRST .+3 ; YES, GO HOME
HRRZ A,BLKLEN-1(A) ; NO, GO UP A BUCKET
JRST HASHL ; NO TRY AGAIN
MOVE PNT,NEWSYM ; PUT OUT, RESTORE, AND QUIT
MOVEM PNT,GENRIG
SETOM QQFLAG
POPJ P,
>; IFN 0
ZERODATA
↑↑QQFLAG:0
↑↑QQBLK: 0
ENDDATA
DSCR QDEC0,1,2 QARSUB QARDEC QPARM QPRDEC;
PRO QDEC0,QDEC1,QDEC2,QSUBSC,QARDEC,QPARM,QPRDEC.
DES These execs finish the declaration of an undeclared identifier by giving
it a type and appropriate goodies. The QDEC execs determine the type from the token
put in PARRIG by the productions. If we need an array, we count the dimensions with
QSUBSC, install them and put out a temp in QARDEC. If we need a procedure, we get a
second semblk in QDEC, ring on formals in QPARM, install parmeter counts in QPRDEC,
and jrst to QARDEC to generate a temp (we assume all procedures are integer
functions).
⊗
;EXECS TO SET THE TBITS FROM THE PARSE TOKEN
↑QDEC2: MOVEI A,0 ; RIGHT - TOP
JRST .+4
↑QDEC0: SKIPA A,[0] ; RIGHT - ONE DOWN
↑QDEC1: SKIPA A,[1] ; RIGHT - ONE DOWN
SKIPA B,[0] ; LEFT - TOP
MOVEI B,1 ; LEFT - ONE DOWN
HRRZ PNT, PARRIG(A) ; GET IT
MOVEI TBITS,0
CAMN PNT, %ILB ; LABEL
JRST [TRO TBITS,LABEL+FORWRD
ERRPRI <UNDECLARED IDENTIFIER DECLARED A LABEL>
JRST .+15]
CAMN PNT, %ISV ; SET
JRST [TRO TBITS,SET
ERRPRI <UNDECLARED IDENTIFIER DECLARED A SET>
JRST .+13]
CAMN PNT,%ARID ; AN ARRAY
JRST [TLO TBITS, SBSCRP!SAFE
ERRPRI <UNDECLARED IDENTIFIER DECLARED AN ARRAY>
JRST .+11]
CAMN PNT,%PCALL ; A PROCEDURE
JRST .+4
CAMN PNT,%S ; ANOTHER PROCEDURE
JRST .+2
CAMN PNT,%FCALL ; YET ANOTHER PROCEDURE
JRST [MOVE TBITS, [XWD EXTRNL,PROCED!INTEGR]
ERRPRI <UNDECLARED IDENTIFIER DECLARED A INTEGER PROCEDURE>
JRST .+3]
CAMN PNT,%ITV ; ITEMVAR
JRST [TRO TBITS, ITMVAR!INTEGR
ERRPRI <UNDECLARED IDENTIFIER DECLARED AN INTEGER ITEMVAR>
JRST .+1]
; IVB GETS NO BITS
CAME PNT,%S ; DONT TURN ON THE CLASIDX IF S
HRLI PNT,CLSIDX ; ALL VARIABLES ARE CLASS MEMBERS
MOVEM PNT,PARRIG(A) ; PUT IT OUT
MOVE PNT,GENLEF(B) ; GET THE UNDECLARED GUY (from UNDEC)
TLNE TBITS, SBSCRP ; IS IT AN ARRAY
SETZM ,DIMNO ; YES, ZERO THE NUMBER OF DIMENSIONS
TRNE TBITS,PROCED ; IF ITS A PROCEDURE...
JRST [GETBLK ; GET A 2D BLOCK
HRLM LPSA,%TLINK(PNT) ; PUT A PNTR TO IT IN TLINK OF PROC
MOVEW %%VARB,VARB ; SAVE THE CURRENT VARB
SETZM VARB ; INITIALIZE A NEW VARB
JRST .+1]
MOVEM TBITS,$TBITS(PNT) ; GIVE IT ITS TYPE
MOVEM PNT,GENRIG(A)
POPJ P,
;;# # BY JFR ZERODATA AND ENDDATA MACROS USED TO BE MISSING
ZERODATA (BUG FIX 9-26-74)
%%VARB:0
ENDDATA
;;# #
↑QSUBSC:
AOS ,DIMNO ; COUNT DIMENSIONS
MOVE PNT, GENLEF +1 ; THE EXPRESSION TEMP ..
PUSHJ P,REMOP ; GETS REMOVED
POPJ P,
DIMNO: 0
↑QARDEC:
MOVE PNT2,GENLEF+2 ;GET THE ARRAY (OR PROCEDURE)
MOVE PNT,DIMNO ; GET #OF DIMENSIONS
HRLM PNT,$ACNO(PNT2) ; RECORD IT
MOVEI TBITS,0 ; TYPE IT
MOVEI D,1 ; DUMMY AC NUMBER FOR ...
PUSHJ P,MARKME ; CREATING A TEMP.
HRL PNT,PNT2 ; PTR TO ARR (OR TO PROC) IN %TLINK( the temp)
MOVEM PNT,GENRIG ; PUT IT OUT
POPJ P,
↑QPARM: MOVE PNT,GENLEF+2 ; GET THE PROCEDURE
HLRZ PNT2,%TLINK(PNT) ; THE SECOND BLOCK
PUSH P,PNT2 ; SAVE IT
MOVE LPSA,GENLEF+1 ; GET THE EXPRESSION
HRRZ TBITS,$TBITS(LPSA) ; GET ITS TYPE
TLO TBITS,VALUE ; MAKE ALL PARAMETERS VALUE...
TRNE TBITS,PROCED ; EXCEPT PROCEDURE EXPRESSIONS
TLC TBITS,VALUE!REFRNC
MOVEM TBITS,BITS
TRNE TBITS,STRING ; IF IT IS A STRING
AOS ,$NPRMS(PNT2) ; INCREMENT STRING PARM COUNT
HLRZ TEMP,$NPRMS(PNT2) ; ALWAYS INCREMENT ARITH PARM COUNT
AOJ TEMP,
HRLM TEMP,$NPRMS(PNT2)
GETBLK ; MAKE A FORMAL
MOVEM TBITS,$TBITS(LPSA) ; GIVE IT A TYPE
PUSHJ P,RNGVRB ; PUT IT ON THE VARB RING
POP P,PNT2 ; GET 2ND BLOCK BACK
SKIPN %TLINK(PNT2) ; IS THIS THE FIRST FORMAL
HRLM LPSA,%TLINK(PNT2) ; YES, PUT A POINTER TO IT IN
; 2D BLOCK OF THE PROCEDURE
MOVE PNT,GENLEF +1 ; GET THE EXPRESSION AND....
JRST REMOP ; KILL IT!!!!! , THEN RETURN QUIETLY
↑QPRDEC:
MOVE PNT,GENLEF+2 ;GET THE PROCEDURE
HLRZ PNT2,%TLINK(PNT) ; GET THE 2D BLOCK
HLRZ TEMP,$NPRMS(PNT2) ; INCREMENT ARITH PARM COUNT
AOJ TEMP,
HRLM TEMP,$NPRMS(PNT2)
HRRZ TEMP,$NPRMS(PNT2) ; STRING PARM COUNT * 2
LSH TEMP,1
HRRM TEMP,$NPRMS(PNT2)
MOVEW VARB,%%VARB ; RESTORE CURRENT VARB
JRST QARDEC ; ASSUME FUNCTION (i.e. make a temp)
BEND
SUBTTL EXECS to handle string constants as comments
BEGIN SCOMM
DSCR SCOMM
PRO SCOMM
DES Remove the damage done by using a string constant
as a comment preceding a statement
⊗
COMMENT ⊗
last prod at S1:
STC drarrow EXEC SCOMM SCAN ¬S1 #Q6
⊗
↑SCOMM1: SKIPA PNT,GENLEF+1 ;SEMANTICS FROM GENLEF+1
↑SCOMM: MOVE PNT,GENLEF ;SEMANTICS OF CONSTANT
PUSHJ P,GETAD ;
TRNN TBITS,STRING ;MUST BE A STRING CONSTANT
JRST [ERR <I THOUGHT IT WAS A STRING COMMENT>,1
POPJ P,]
JRST REMOP
BEND SCOMM
SUBTTL START!CODE (inline) EXECS
BEGIN INLINE
ZERODATA (START!CODE VARIABLES)
?ACSWCH: 0 ;ACCESS HAS BEEN SEEN (-1) OR NOT (0)
?CODSEM: 0 ;SEMANTICS OF ADDRESS FIELD (IF VBL)
?CODVAL: 0 ;VALUE OF ADDRESS, AC, INDEX FIELDS (CONST STUFF)
?INSTBL: 0 ;PTR TO SIXBIT TABLE OF OPCODES, IF HAS BEEN READ IN
?OPCOD: 0 ;OPCODE OF INSTRUCTION BEING ASSEMBLED
;OPDUN -- on if opcode field has been scanned. Also used as flag
; to EMITER that the instruction going out is a START!CODE
; produced intruction -- avoids optimizations of various forms
↑OPDUN: 0
DATA (START!CODE VARIABLES)
; THIS IS THE ENTER BLOCK FOR THE SIXBIT OPCODE TABLE USED TO
; ALLOW SYMBOLIC OPCODES IN START!CODE INSTRUCTIONS
NOTENX <
TNAME: OPNAME
'OPS '
TWORD3: 0
TPPN: OPPPN
>;NOTENX
ENDDATA
DSCR CODNIT, WRDNIT, ONEWRD, SETSIX, SETOP, CODIND, CODREG, etc.
PRO CODNIT WRDNIT ONEWRD SETSIX SETOP CODIND CODREG CODLIT ERRCOL ERRCOM
DES These routines handle the START!CODE/QUICK!CODE syntax.
The only surprise is a table of SIXBIT opcodes which are read in
when needed. No variable with the same name as one of these opcodes
may be used within a CODE block.
⊗
↑CODNIT:
JRST .+1(B) ;START!CODE CLEARS, QUICK!CODE DOESN'T
PUSHJ P,ALLSTO ;CLEAR THE WORLD
; JRST WRDNIT ;FALL THROUGH
↑WRDNIT:
SETZM ACSWCH ;RESET ACCESS SWITCH
SETZM OPCOD ;OP, AC, INDEX, INDR COLLECTED HERE
SETZM OPDUN
SETZM CODVAL ;OPDUN IS A FLAG, CODVAL IF CONST
SETZM CODSEM ;SEMANTICS OF ADDR IF NON-CONST
;;#JU# RHT (DEL 1 LINE) -- DONT HURT ACKTAB 10-23-72
MOVSI TEMP,INLIN ;SET SPECIAL SCANNER BIT SO THAT
ORM TEMP,SCNWRD ; @ IS TREATED AS A DELIM,
; (DCS -- 8/13/70) PNAME+1 ZEROED
NOCODE: POPJ P,
↑ONEWRD:
SKIPE A,OPCOD
HRRZS CODVAL
OR A,CODVAL
HRL C,A
HLLZS A ;PUT OP CODE,UNRELOC ADDR IN PLACE
SKIPN OPDUN ;WAS ANYTHING SEEN?
JRST NOCODE ; NO, NULL STATEMENT
SETOM OPDUN ;TELL EMITER DOING INLINE CODE
TRO A,NOUSAC!USADDR!NORLC ;ASSUME CONSTANT ADDR FIELD
SKIPN PNT,CODSEM ;WELL, WHICH IS IT?
JRST EMITER ;EMIT IT
MOVE TBITS,$TBITS(PNT) ;GET BITS FOR FXTWO SET
TRC A,USADDR!NORLC!FXTWO ;ASSUME A STRING
;; #JRL# 9-19-72 A STRING ITEMVAR IS NOT A STRING
TDNN TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;IF SBSCRP OR ¬STRING,
;; #JRL#
TRNN TBITS,STRING ; REVERSE ASSUMPTION
TRZ A,FXTWO
;; #PK# 12-2-73 DO A REMOP HERE
PUSHJ P,EMITER ;GO EMIT CODE
JRST REMOP ;REMOP IT
;; #PK#
↑SETSIX:
MOVEI A,0 ;COLLECT SIXBIT
HRRZ TEMP,PNAME ;LENGTH
JUMPE TEMP,.+2 ;IGNORE NULL STRINGS
CAILE TEMP,6 ;MUST BE OPCODE-SIZED
POPJ P, ; NO PRINT NAME, NO SIXBIT
MOVE C,[POINT 6,A]
MOVE LPSA,PNAME+1 ;BYTE POINTER TO STRING
LOOP: SOJL TEMP,LOKSIX ;GOT IT CONVERTED, LOOK IT UP
ILDB D,LPSA ;GET CHAR
SUBI D,40
IDPB D,C ;COLLECT SIXBIT
JRST LOOP
LOKSIX:
Comment ⊗ might be an OPCOD -- will assume it is if it is in
the opcode table. To find out, we may have to read said
table in. Then we will do a linear search to discover
the correct instruction code ⊗
NOTENX <
SKIPE B,INSTBL ;TABLE IN CORE?
JRST TABLIN ;YES, ADDRESS IN B
;;#GN# DCS 2-6-72 (1-1) INCLUDE UUO'S, STANFORD UUO'S
EXPO <
SIZZZZ←←700-40
>;EXPO
NOEXPO <
SIZZZZ←←724-40
>;NOEXPO
MOVEI C,SIZZZZ+4 ;SIZE OF TABLE, PLUS BREATHING ROOM
;; #GN#
PUSHJ P,CORGET ;GET SOME SPACE FOR IT
ERR <DRYROT -- INLINE CODE>
SUBI B,1
HRLI B,-SIZZZZ ;IOWD -SIZE,ADDR-1 FOR OP TABLE
MOVEM B,INSTBL ;STORE ITS ADDRESS
MOVEI B+1,0 ;END COMMAND LIST
SETZM TWORD3
MOVE TEMP,[OPPPN]
MOVEM TEMP,TPPN ;RESTORE OPCODE FILE PPN
OPEN 17,[17
OPDEV
0]
ERR <DRYROT -- INLINE CODE>
LOOKUP 17,TNAME
ERR <DRYROT -- INLINE CODE>
INPUT 17,B ;READ THE OP TABLE
RELEASE 17,
>;NOTENX
TENX<
SKIPE INSTBL ;TABLE READ IN?
JRST TABLIN ;YES
PUSH P,A
HRROI B,[OPFILE]
HRLZI A,100001 ;OLD FILE, SHORT FORM
JSYS GTJFN
ERR <CAN'T FIND OPFILE>
HRLI A,400000 ;XWD FORK, JFN
JSYS GET ;OPFILE IS SSHARED
SETOM INSTBL ;MARK THAT THE TABLE IS HERE
POP P,A
>;TENX
TABLIN:
Comment ⊗
B pnts to current table entry (LH IS -COUNT)
A is soon be sixbit for OPcode being sought
⊗
NOTENX<
MOVE D,[CAME A,(B)] ;SET UP QUICK SEARCH LOOP
MOVE D+1,[AOBJN B,D] ;ITERATION CONTROL
MOVE D+2,[JRST TSTFND] ;OUT OF ACS
AOJA B,D ;INITIAL ADD
TSTFND: JUMPGE B,UNFNDOP ;SEARCH EXHAUSTED
FNDOPC: SUB B,INSTBL ;GET OP CODE IN OCTAL
;; #GN#
ADDI B,37 ;ADJUST -- FIRST 40 NOT LOADED
;;#GN# (1-1)
MOVEM B,GENRIG ;STORE FOR A WHILE
MOVE TEMP,%OPC ;MARK OPCODE FOUND
MOVEM TEMP,PARRIG ;SAVE FOR PARSER
UNFNDOP: POPJ P,
>;NOTENX
TENX<
COMMENT !
In TENEX, the opcode table is created by MAKTAB.TNX to
be a SSAVEd file. It consists of the operations names (in sixbit),
their opcodes, in bucket-driven link lists.
!
OPBUKT←←=307 ;NUMBER OF BUCKETS
BUKPAG←←600 ;STARTING PAGE FOR OPTABLE
BUKTST←←BUKPAG*1000 ;STARTING ADDR FOR BUCKETS
MOVM B,A ;ABS(OPCODE)
IDIVI B,OPBUKT ;COMPUTE BUCKET NUMBER IN C
MOVE B,BUKTST(C) ;GET BUCKET POINTER
TABLI1: CAMN A,(B) ;IS THIS THE RIGHT OPCODE?
JRST FNDOPC ;YES
SKIPN B,2(B) ;CDR DOWN LIST, ARE WE TO NIL
JRST UNFNDOP ;YES, NO MORE
JRST TABLI1 ;NO, KEEP GOING
FNDOPC: MOVE B,1(B) ;PICK UP THE OPCODE
MOVEM B,GENRIG ;STORE FOR A WHILE
MOVE TEMP,%OPC ;MARK OPCODE FOUND
MOVEM TEMP,PARRIG ;SAVE FOR PARSER
UNFNDOP: POPJ P, ;RETURN, ANSWER IN B
>;TENX
↑CESSGO:MOVE TEMP,OPDUN ;SAVING OPDUN
MOVEM TEMP,T.OPDUN
SETZM OPDUN
POPJ P,
↑CESSOK: ;THIS EXEC TO DO THE ACCESS CONSTRUCT
MOVE PNT, GENLEF+1 ;GET THE @E
GENMOV ACCESS, GETD ;MAKE SURE THE EXPR IS AVAILABLE
SETOM ACSWCH ;TELL THE CODVBL GUY NOT TO COMPLAIN
; PUSHJ P,REMOP ;DESTROY TEMPORARIES WITH ABANDON
MOVE TEMP,T.OPDUN ;RESTORE OPDUN
MOVEM TEMP,OPDUN
POPJ P,
T.OPDUN:0 ;PLACE TO PUT OPDUN
↑CODID: SKIPN PNT,GENLEF+1 ;MUST BE DEFINED
ERR <UNDEFINED INSTRUCTION ELEMENT>,1,FRGET
MOVNI TBITS2,1 ;ASSUME NO OPCODE SEEN YET
HLLOS TEMP,OPDUN ;MARK SOMETHING SEEN
JUMPG TEMP,MAYBOP ;NO OPCODE SEEN, MIGHT BE CNST OPCODE
NONOPC: SKIPN CODSEM ;CHECK TWO ADDRESS FIELDS
SKIPE CODVAL
ERR <TWO ADDRESS FIELDS>,1
MOVEI TBITS2,0 ;OPCODE SEEN PREVIOUSLY
MAYBOP: SETOM OPDUN ;NO MORE OPCODES ALLOWED
PUSHJ P,GETAD
TLNN TBITS,CNST ;CONSTANT?
JRST CODVBL ; NO, MUST BE VARIABLE ADDR FIELD
GENMOV (CONV,INSIST,INTEGR) ;GET INTEGER CONSTANT
MOVE A,$VAL(PNT)
JUMPL TBITS2,STROPC ;OPCODE CONSTANT (ASSUME SO, ANYWAY)
MOVEM A,CODVAL ;NOT OPCODE, SAVE HERE
JRST REMOP ;DON'T NEED CONST ANY MORE
STROPC: ORM A,OPCOD ;NON-DESTRUCTIVE STORE
JRST REMOP ;DON'T NEED SEMANTICS
CODVBL: TLNN SBITS,FIXARR ;ACCEPT CNST-CNST-CNST ARRAY
TLNN SBITS,ARTEMP!STTEMP ; AND VARIABLES
JRST VBLOK
SKIPN ACSWCH ;DON'T COMPLAIN IF ACCESS HAPPENED
ERR <EXPRESSION NOT LEGAL AS INSTRUCTION ADDRESS>,1
VBLOK: MOVEM PNT,CODSEM ;SAVE SEMANTICS
POPJ P,
↑SETOP: HLLOS TEMP,OPDUN ;SET SOMETHING SEEN
JUMPL TEMP,TWOOP ;TWO OPCODES
SETOM OPDUN ;MARK OPCODE DONE
MOVE A,GENLEF
NOTENX<
DPB A,[POINT 9,OPCOD,8] ;OPCOD POSITION
>;NOTENX
TENX<
MOVEM A,OPCOD ;36-BIT OPCODE
>;
POPJ P,
TWOOP: ERR <TWO OPCODES>,1,FRGET
↑CODIND:
HLLOS OPDUN ;MARK SOMETHING SEEN
MOVSI TEMP,20 ;INDIRECT BIT
ORM TEMP,OPCOD ;PUT IN OPCOD WORD
FRGET: POPJ P,
↑CODREG:
HLLOS OPDUN
SKIPN PNT,GENLEF+1 ;MUST BE A CONSTANT
ERR <NON-CONSTANT AC FIELD>,1,REMOP
GENMOV (CONV,GETD!INSIST,INTEGR)
TLNN TBITS,CNST ;MUST BE A CONSTANT
ERR <NON-CONSTANT AC FIELD>,1,REMOP
MOVE TEMP,$VAL(PNT) ;GET ITS VALUE
DPB TEMP,[POINT 4,OPCOD,12] ;DEPOSIT IN AC FIELD
JRST REMOP
↑CODX: HLLOS OPDUN
SKIPN PNT,GENLEF+1 ;MUST BE A CONSTANT
ERR <NON-CONSTANT INDEX FIELD>,1,REMOP
GENMOV (CONV,GETD!INSIST,INTEGR)
TLNN TBITS,CNST
ERR <NON-CONSTANT INDEX FIELD>,1,REMOP
MOVE TEMP,$VAL(PNT)
DPB TEMP,[POINT 4,OPCOD,17] ;INDEX FIELD
JRST REMOP
↑CODLIT:
HLLOS OPDUN
SKIPN PNT,GENLEF+1
ERR <NON-CONSTANT LITERAL>,1,REMOP
MOVE TBITS,$TBITS(PNT)
TLNN TBITS,CNST
ERR <NON-CONSTANT LITERAL>,1,REMOP
SKIPN CODVAL ;CHECK FOR TWO ADDRESS FIELDS
SKIPE CODSEM
ERR <TWO ADDRESS FIELDS>,1,REMOP
CODBK: MOVEM PNT,CODSEM
MOVSI TEMP,INLIN ;TURN SPECIAL SCANNING BIT
ORM TEMP,SCNWRD ;BACK ON
POPJ P,
↑LITOFF: ;TURN OFF SPECIAL @ SCANNING BIT IN SCNWRD
; (CALLED WHEN SCANNING LITERALS, AND WHEN LEAVING A
; START!CODE BLOCK)
MOVSI TEMP,INLIN
ANDCAM TEMP,SCNWRD
POPJ P,
↑ERRCOL:
ERR <UNDEFINED LABEL OR BAD SYNTAX>,1
POPJ P,
↑ERRCOM:
ERR <COMMA USED IN WRONG MANNER>,1
POPJ P,
BEND INLINE
SUBTTL COUNTER SYSTEM EXECS
BEGIN COUNT
DSCR KOUNT1,KOUNT2,KOUNT3,KOUNT4,KOUNT5 -- INSERT A COUNTER
PRO KOUNT1 KOUNT2 KOUNT3 KOUNT4 KOUNT5
DES These exec routines insert a counter into the code and a
marker into the output listing. They are NO-OP's unless the
/K switch is specified. As a listing file is necessary for /K,
it is not necessary to check SCANWD for listing. KOUNT2 will
someday do the right thing for multiple labels. KOUNT3 , KOUNT4,
and KOUNT5 insert a different marker for counters in expressions.
The multiplicity of routines for expression counters comes from
the necessity of having the counter immediately after the reserved
word in order for the analysis routine to work right.
⊗
↑KOUNT6: SKIPA C,[","] ;SHOULD FOLLOW ","
↑KOUNT5: MOVEI C,"(" ;SHOULD FOLLOW "("
JRST KOUNT4+1
↑KOUNT3: SKIPA C,["N"] ;SHOULD FOLLOW "THEN"
↑KOUNT4: MOVEI C,"E" ;SHOULD FOLLOW "ELSE"
MOVEI B,3 ;MARKER IS BETA ('03)
MOVEI D,LSTOU1 ;USE THIS LIST ROUTINE
JRST KOUNT1+2
↑KOUNT2: ;EVENTUALLY, CHECK FOR MULTIPLE LABELS
↑KOUNT1: MOVEI B,2 ;MARKER IS ALPHA ('02)
MOVEI D,LSTOUT ;USE THIS ROUTINE
SKIPN KOUNT ;ARE WE INSERTING COUNTERS
POPJ P, ;NO
MOVE A,[AOS 0]
PUSHJ P,CODOUT ;PUT THE ADD INSTR INTO THE CODE
AOS KCOUNT ;COUNT THE COUNTERS
MOVE A,PCNT
SUBI A,1
QPUSH (KPDP,) ;SAVE ADDRESS OF AOS
MOVEI A,177 ;PUT A MARKER INTO
PUSHJ P,(D) ; THE LIST FILE
MOVEI C,177 ;NEEDED IN CASE WE'RE CALLING LSTOU1
MOVE A,B ;GET THE CHARACTER FOR THE MARK
PUSHJ P,(D)
POPJ P,
BEND COUNT
SUBTTL ARRAY DECLARATION AND INDEXING EXECS